@@ -1,5 +1,103 @@
Revision history for Perl extension Plack
+Take a look at http://github.com/miyagawa/Plack/issues for the planned changes before 1.0 release.
+
+0.9911 Tue Feb 23 01:55:04 PST 2010
+ - Removed psgix.io extension to fix streaming choke issue on HTTP::Server::PSGI (tomyhero)
+
+0.9910 Mon Feb 22 19:03:17 PST 2010
+ - This is the first non-dev release since 0.99. Read all the change logs below.
+ - Support streaming in JSONP (hiratara)
+ - Fixed various handler docs (markstos)
+ - Added Starman and Twiggy to benchmark script
+ - INCOMPATIBLE: Loader now prefers Twiggy when AnyEvent is loaded
+ - Implemented (experimental) psgix.io and psgix.input.buffered extensions
+ - Fixed Plack::Request POST parser to use psgix.input.buffered for better performance
+ - Added PLACK_ENV environment support in plackup #63
+ - Added HTTPExceptions middleware
+ - Added Recursive middleware
+
+0.99_05 Wed Feb 10 12:46:05 PST 2010
+ - Changed the Loader command line options to -L from -l
+ - Runner now folds --host, --port and --socket to --listen and vice verca
+ - Added -D and --daemonize to plackup/Runner standard options
+ - Fixed FCGI handler to work with the new --listen and --daemonize option
+ - Fixed a bug in static.t where it chdir's before loading modules
+ - Renamed Writer to BufferedStreaming middleware and added docs
+ - Support streaming apps in Shotgun loader
+ - Falls back to Standalone handler when auto-detected backend is not available (hiratara)
+ - Support chunked-input in HTTP::Request->to_psgi
+ - Make the Reloader work with preforked server (chiba)
+ - Added 'Auto' backend in TempBuffer
+ - Added Nomo backend to the benchmark script
+ - Updated HTTP::Server::PSGI to support experimental psgix.input.buffered
+ - Plack::Request now honors psgix.input.buffered to see psgi.input is seekable
+ - Renamed Standalone handler to HTTP::Server::PSGI for consistency while keeping
+ 'Standalone' as a nickname
+
+0.99_04 Fri Feb 5 23:10:48 PST 2010
+ - Updated Test suite for multiple request headers to relax a bit for AE::HTTPD
+ - Added a test for large POST body which revealed FCGI::Client bug
+ - Added a handler for HTTP::Server::Simple::PSGI
+ - Depend on a decent version of URI (tomyhero)
+ - Reworked Loader API so the default loader can autodetect the backend again
+ - run_app now doesn't use Try::Tiny but use plain eval {}
+
+0.99_03 Wed Feb 3 16:09:14 PST 2010
+ - Use 0 as a default address in the server_ready hook in Plack::Runner
+ - Document Plack::Handler naming scheme
+ - Fixed how Plack::Server::Standalone saves args
+ - Supported streaming interface in Cascade and URLMap
+ - mentions awesome WSGI Paste in Plack documentation
+ - Removed URI caching in Plack::Request since it's fast enough
+ - Fixed packaging issue due to Module::Install::Share bug (rafl)
+ - Support 'file' option in App::File and its subclasses
+ - Fixed SCRIPT_NAME and PATH_INFO in App::CGIBin
+ - Fixed App::Directory and ::File not to use Path::Class and its canonicalization.
+ It's now 300% faster!
+
+0.99_02 Sat Jan 30 22:10:45 PST 2010
+ - Fixed PerlIO::TempBuffer to work with 5.8 and 5.11.3
+ - Do not use <$input> in FCGIDispatcher
+ - Skip fcgi_client.t unless explicitly stated (clkao)
+ - clarify and drop some CPAN dependencies (andk)
+
+0.99_01 Fri Jan 29 14:02:04 PST 2010
+ Incompatible Changes
+ - Rename Standalone servers to HTTP::Server::PSGI
+ - Rename Plack::Server adapters to Plack::Handler. These changes should be transparnt
+ since we have a compatible code to work with the older names as well.
+ - Dropped sendfile(2) AIO support from Standalone server
+ - Plack::Request and Response are now in core, deprecating many methods.
+ Read `perldoc Plack::Request` and its INCOMPATIBILITIES section
+
+ New Features
+ - New middleware: WrapCGI to convert a single CGI script into a PSGI applciation
+ - Support psgix.logger and psgix.session in Plack::Request
+ - New logger middleware: NullLogger, SimpleLogger, Log4perl and LogDispatch
+ - Refactored Loader classes and added a new Shotgun loader (like rack's Shotgun)
+ - Added -l option to plackup which specifies the Loader backend
+ - New middleware: Refresh reloads modules in %INC in every N seconds
+ - Wraps -e code with 'builder { }' by default. You can also use with *.psgi to add middleware
+ components without editing the file!
+
+ Bug Fixes and Improvements
+ - Do not call ->canonical in HTTP::Message::PSGI to keep the URI encoded params in Plack::Test
+ tests (rafl, t0m)
+ - Fixed a bug in stupid corner case in HTTP::Message::PSGI where passed URI has UTF-8 encoded
+ strings *and* URI escaped UTF-8 bytes. (chmrr)
+ - Depend on new HTTP::Request::AsCGI that has better REQUEST_URI
+ - Plack::Runner/plackup does not autoload AccessLog in CGI mode anymore
+ - Added server_ready hook to PSGI servers so you can disable them in tests etc. (clkao, rafl)
+ - Escape user-supplied values in AccessLog to avoid control sequence injection (tokuhirom, kazuho)
+ - Support -foo (single dash) style option in Plack::Runner and plackup
+ - Relax the runtime.t check since it still fails on low-res time environments
+ - Now depends on Digest::MD5, HTTP::Body and Hash::MultiValue
+ - Revert the 'require' in load_psgi to do 'do'
+ - Delay load unnecessary modules in Plack::Runner
+ - Fixed psgi.multiprocess value on HTTP::Server::PSGI
+ - PSGI/1.1 support in Lint
+
0.9031 Mon Jan 11 11:29:04 PST 2010
- Fixed Plack::App::Directory directory listing by switching to Plack::MIME (tokuhirom)
This has been broken since 0.9025
@@ -42,18 +42,13 @@ inc/Module/Install/ReadmeFromPod.pm
inc/Module/Install/Repository.pm
inc/Module/Install/Scripts.pm
inc/Module/Install/Share.pm
-inc/Module/Install/TestBase.pm
inc/Module/Install/Win32.pm
inc/Module/Install/WriteAll.pm
-inc/Spiffy.pm
-inc/Test/Base.pm
-inc/Test/Base/Filter.pm
-inc/Test/Builder.pm
-inc/Test/Builder/Module.pm
inc/Test/More.pm
inc/Test/Requires.pm
inc/Test/TCP.pm
lib/HTTP/Message/PSGI.pm
+lib/HTTP/Server/PSGI.pm
lib/Plack.pm
lib/Plack/App/Cascade.pm
lib/Plack/App/CGIBin.pm
@@ -62,42 +57,69 @@ lib/Plack/App/FCGIDispatcher.pm
lib/Plack/App/File.pm
lib/Plack/App/PSGIBin.pm
lib/Plack/App/URLMap.pm
+lib/Plack/App/WrapCGI.pm
lib/Plack/Builder.pm
lib/Plack/Component.pm
+lib/Plack/Handler.pm
+lib/Plack/Handler/Apache1.pm
+lib/Plack/Handler/Apache2.pm
+lib/Plack/Handler/CGI.pm
+lib/Plack/Handler/FCGI.pm
+lib/Plack/Handler/HTTP/Server/PSGI.pm
+lib/Plack/Handler/HTTP/Server/Simple.pm
+lib/Plack/Handler/Standalone.pm
lib/Plack/HTTPParser.pm
lib/Plack/HTTPParser/PP.pm
lib/Plack/Loader.pm
-lib/Plack/Loader/Reloadable.pm
+lib/Plack/Loader/Restarter.pm
+lib/Plack/Loader/Shotgun.pm
lib/Plack/Middleware.pm
lib/Plack/Middleware/AccessLog.pm
lib/Plack/Middleware/AccessLog/Timed.pm
lib/Plack/Middleware/Auth/Basic.pm
+lib/Plack/Middleware/BufferedStreaming.pm
lib/Plack/Middleware/Chunked.pm
lib/Plack/Middleware/Conditional.pm
lib/Plack/Middleware/ConditionalGET.pm
lib/Plack/Middleware/ContentLength.pm
lib/Plack/Middleware/ContentMD5.pm
lib/Plack/Middleware/ErrorDocument.pm
+lib/Plack/Middleware/HTTPExceptions.pm
lib/Plack/Middleware/JSONP.pm
lib/Plack/Middleware/Lint.pm
+lib/Plack/Middleware/Log4perl.pm
+lib/Plack/Middleware/LogDispatch.pm
lib/Plack/Middleware/MethodOverride.pm
+lib/Plack/Middleware/NullLogger.pm
lib/Plack/Middleware/RearrangeHeaders.pm
+lib/Plack/Middleware/Recursive.pm
+lib/Plack/Middleware/Refresh.pm
lib/Plack/Middleware/Runtime.pm
lib/Plack/Middleware/SimpleContentFilter.pm
+lib/Plack/Middleware/SimpleLogger.pm
lib/Plack/Middleware/StackTrace.pm
lib/Plack/Middleware/Static.pm
lib/Plack/Middleware/Writer.pm
lib/Plack/Middleware/XFramework.pm
lib/Plack/Middleware/XSendfile.pm
lib/Plack/MIME.pm
+lib/Plack/Request.pm
+lib/Plack/Request/Upload.pm
+lib/Plack/Response.pm
lib/Plack/Runner.pm
lib/Plack/Server.pm
lib/Plack/Server/Apache1.pm
lib/Plack/Server/Apache2.pm
lib/Plack/Server/CGI.pm
lib/Plack/Server/FCGI.pm
+lib/Plack/Server/README
+lib/Plack/Server/ServerSimple.pm
lib/Plack/Server/Standalone.pm
lib/Plack/Server/Standalone/Prefork.pm
+lib/Plack/TempBuffer.pm
+lib/Plack/TempBuffer/Auto.pm
+lib/Plack/TempBuffer/File.pm
+lib/Plack/TempBuffer/PerlIO.pm
lib/Plack/Test.pm
lib/Plack/Test/MockHTTP.pm
lib/Plack/Test/Server.pm
@@ -113,14 +135,29 @@ share/face.jpg
share/kyoto.jpg
t/00_compile.t
t/FCGIUtils.pm
+t/HTTP-Message-PSGI/utf8_req.t
+t/Plack-Handler/apache1.t
+t/Plack-Handler/apache2.t
+t/Plack-Handler/cgi.t
+t/Plack-Handler/fcgi.t
+t/Plack-Handler/fcgi_client.t
+t/Plack-Handler/http_server_simple.t
+t/Plack-Handler/standalone-prefork.t
+t/Plack-Handler/standalone.t
t/Plack-HTTPParser-PP/simple.t
+t/Plack-Loader/auto.t
+t/Plack-Loader/auto_fallback.t
+t/Plack-Loader/shotgun.t
t/Plack-Middleware/access_log.t
t/Plack-Middleware/access_log_timed.t
t/Plack-Middleware/auth_basic.t
t/Plack-Middleware/auth_basic_simple.t
+t/Plack-Middleware/bufferedstreaming.t
t/Plack-Middleware/cascade.t
+t/Plack-Middleware/cascade_streaming.t
t/Plack-Middleware/cgi-bin/hello.cgi
t/Plack-Middleware/cgi-bin/hello2.cgi
+t/Plack-Middleware/cgi-bin/hello3.cgi
t/Plack-Middleware/cgibin.t
t/Plack-Middleware/chunked.t
t/Plack-Middleware/conditional.t
@@ -129,16 +166,26 @@ t/Plack-Middleware/content_length.t
t/Plack-Middleware/error_document.t
t/Plack-Middleware/errors/404.html
t/Plack-Middleware/errors/500.html
+t/Plack-Middleware/file.t
t/Plack-Middleware/htpasswd
+t/Plack-Middleware/httpexceptions.t
+t/Plack-Middleware/httpexceptions_streaming.t
t/Plack-Middleware/jsonp.t
t/Plack-Middleware/lint.t
+t/Plack-Middleware/log4perl.t
+t/Plack-Middleware/log_dispatch.t
t/Plack-Middleware/method_override.t
t/Plack-Middleware/order.t
t/Plack-Middleware/prefix.t
t/Plack-Middleware/psgibin.t
t/Plack-Middleware/rearrange_headers.t
+t/Plack-Middleware/recursive/base.t
+t/Plack-Middleware/recursive/streaming.t
+t/Plack-Middleware/recursive/throw.t
+t/Plack-Middleware/recursive/throw_streaming.t
t/Plack-Middleware/runtime.t
t/Plack-Middleware/simple_content_filter.t
+t/Plack-Middleware/simple_logger.t
t/Plack-Middleware/stacktrace.t
t/Plack-Middleware/static.t
t/Plack-Middleware/static.txt
@@ -146,19 +193,42 @@ t/Plack-Middleware/static_env.t
t/Plack-Middleware/urlmap.t
t/Plack-Middleware/urlmap_builder.t
t/Plack-Middleware/urlmap_env.t
-t/Plack-Middleware/writer.t
+t/Plack-Middleware/wrapcgi.t
t/Plack-Middleware/xframework.t
t/Plack-Middleware/xsendfile.t
t/Plack-MIME/add_type.t
t/Plack-MIME/basic.t
t/Plack-MIME/fallback.t
-t/Plack-Server/apache1.t
-t/Plack-Server/apache2.t
-t/Plack-Server/cgi.t
-t/Plack-Server/fcgi.t
-t/Plack-Server/fcgi_client.t
-t/Plack-Server/standalone-prefork.t
-t/Plack-Server/standalone.t
+t/Plack-Request/base.t
+t/Plack-Request/body.t
+t/Plack-Request/content-on-get.t
+t/Plack-Request/content.t
+t/Plack-Request/cookie.t
+t/Plack-Request/double_port.t
+t/Plack-Request/foo1.txt
+t/Plack-Request/foo2.txt
+t/Plack-Request/hostname.t
+t/Plack-Request/many_upload.t
+t/Plack-Request/multi_read.t
+t/Plack-Request/new.t
+t/Plack-Request/parameters.t
+t/Plack-Request/params.t
+t/Plack-Request/path_info.t
+t/Plack-Request/readbody.t
+t/Plack-Request/request_uri.t
+t/Plack-Request/upload-basename.t
+t/Plack-Request/upload-large.t
+t/Plack-Request/upload.t
+t/Plack-Request/uri.t
+t/Plack-Request/uri_utf8.t
+t/Plack-Response/body.t
+t/Plack-Response/cookie.t
+t/Plack-Response/new.t
+t/Plack-Response/redirect.t
+t/Plack-Response/response.t
+t/Plack-Runner/options.t
+t/Plack-Server/compat.t
+t/Plack-TempBuffer/print.t
t/Plack-Test/2args.t
t/Plack-Test/cookie.t
t/Plack-Test/hello.t
@@ -1,5 +1,5 @@
---
-abstract: 'PSGI toolkit and servers'
+abstract: 'Perl Superglue for Web frameworks and Web Servers (PSGI toolkit)'
author:
- '- Tatsuhiko Miyagawa'
build_requires:
@@ -10,7 +10,7 @@ build_requires:
configure_requires:
ExtUtils::MakeMaker: 6.42
distribution_type: module
-generated_by: 'Module::Install version 0.91'
+generated_by: 'Module::Install version 0.92'
license: perl
meta-spec:
url: http://module-build.sourceforge.net/META-spec-v1.4.html
@@ -27,15 +27,15 @@ requires:
Devel::StackTrace::AsHTML: 0
File::ShareDir: 1.00
Filesys::Notify::Simple: 0
- Filter::Util::Call: 0
+ HTTP::Body: 1.06
+ Hash::MultiValue: 0.05
LWP: 5.814
- Path::Class: 0
Pod::Usage: 0
Try::Tiny: 0
- URI: 0
+ URI: 1.36
parent: 0
perl: 5.8.1
resources:
license: http://dev.perl.org/licenses/
repository: git://github.com/miyagawa/Plack.git
-version: 0.9031
+version: 0.9911
@@ -10,7 +10,7 @@ all_from 'lib/Plack.pm';
readme_from 'lib/Plack.pm';
requires 'LWP', 5.814; # HTTP::Status, HTTP::Headers and HTTP::Request
-requires 'URI';
+requires 'URI', 1.36;
requires 'Pod::Usage'; # plackup
requires 'File::ShareDir', '1.00'; # Plack::Test::Suite
requires 'Try::Tiny';
@@ -21,9 +21,8 @@ requires 'Devel::StackTrace::AsHTML'; # Middleware::StackTrace
requires 'Filesys::Notify::Simple'; # plackup -r
-# TODO: they can go away once we create Plack-Middlewares dist
-# Middleware::Static and App::File
-requires 'Path::Class';
+requires 'Hash::MultiValue', 0.05; # Plack::Request
+requires 'HTTP::Body', 1.06; # Plack::Request
build_requires 'Test::More', 0.88;
build_requires 'Test::TCP', 0.11;
@@ -35,7 +34,6 @@ author_tests 'xt';
install_share 'share';
install_script 'scripts/plackup';
-use_test_base;
auto_include;
auto_install;
auto_set_repository;
@@ -1,23 +1,25 @@
NAME
- Plack - PSGI toolkit and servers
+ Plack - Perl Superglue for Web frameworks and Web Servers (PSGI toolkit)
DESCRIPTION
- Plack is a set of PSGI reference server implementations and helper
- utilities for Web application frameworks, exactly like Ruby's Rack.
+ Plack is a set of tools for using PSGI stack. It contains middleware
+ components, a reference server and utilities for Web application
+ frameworks. Plack is like Ruby's Rack or Python's Paste for WSGI.
See PSGI for the PSGI specification and PSGI::FAQ to know what PSGI and
Plack are and why we need them.
MODULES AND UTILITIES
- Plack::Server
- Plack::Server is a namespace for PSGI server implementations. We have
- Standalone, CGI, FCGI, Apache, AnyEvent, Coro, Danga::Socket and many
- server environments that you can run PSGI applications on.
+ Plack::Handler
+ Plack::Handler and its subclasses contains adapters for web servers. We
+ have adapters for Standalone, CGI, FCGI, Apache, AnyEvent, Coro,
+ Danga::Socket and many server environments that you can run PSGI
+ applications on.
- See Plack::Server how to write your own server implementation.
+ See Plack::Handler how to write your own adapters.
Plack::Loader
- Plack::Loader is a loader to load one of Plack::Server backends and run
+ Plack::Loader is a loader to load one of Plack::Server adapters and run
PSGI application code reference with it.
Plack::Util
@@ -29,7 +31,24 @@ MODULES AND UTILITIES
reference in the command line or configuration files, so Plack uses a
convention that you need a file named "app.psgi" or alike, which would
be loaded (via perl's core function "do") to return the PSGI application
- code reference. See eg/dot-psgi directory for the example ".psgi" files.
+ code reference.
+
+ # Hello.psgi
+ my $app = sub {
+ my $env = shift;
+ # ...
+ return [ $status, $headers, $body ];
+ };
+
+ If you use a web framework, chances are that they provide a helper
+ utility to automatically generate these ".psgi" files for you, such as:
+
+ # MyApp.psgi
+ use MyApp;
+ my $app = sub { MyApp->run_psgi(@_) };
+
+ It's important that the return value of ".psgi" file is the code
+ reference. See eg/dot-psgi directory for more examples of ".psgi" files.
plackup, Plack::Runner
plackup is a command line launcher to run PSGI applications from command
@@ -101,16 +120,43 @@ CONTRIBUTING
COPYRIGHT
Copyright 2009- Tatsuhiko Miyagawa
-AUTHORS
+AUTHOR
Tatsuhiko Miyagawa
- Yuval Kogman
+CONTRIBUTORS
+ Yuval Kogman (nothingmuch)
+
+ Tokuhiro Matsuno (tokuhirom)
+
+ Kazuhiro Osawa (Yappo)
+
+ Kzzuho Oku
+
+ Florian Ragwitz (rafl)
+
+ Chia-liang Kao (clkao)
+
+ Masahiro Honma (hiratara)
+
+ Daisuke Murase (typester)
+
+ John Beppu
+
+ Matt S Trout (mst)
+
+ Shawn M Moore (Sartak)
+
+ Stevan Little
+
+ Hans Dieter Pearcey (confound)
+
+ Tomas Doran (t0m)
- Tokuhiro Matsuno
+ mala
- Kazuhiro Osawa
+ Mark Stosberg
- Kazuho Oku
+ Aaron Trevena
SEE ALSO
PSGI <http://plackperl.org/>
@@ -11,13 +11,29 @@ use URI;
use String::ShellQuote;
my $app = 'eg/dot-psgi/Hello.psgi';
-my $ab = 'ab -n 100 -c 10 -k';
+my $ab = 'ab -t 1 -c 10 -k';
my $url = 'http://127.0.0.1/';
-my @backends = grep eval "require Plack::Server::$_; 1",
- qw( AnyEvent Standalone Standalone::Prefork ServerSimple Coro Danga::Socket POE );
+my @try = (
+ [ 'AnyEvent::HTTPD' ],
+ [ 'HTTP::Server::PSGI' ],
+ [ 'HTTP::Server::PSGI', ' (workers=10)', max_workers => 10 ],
+ [ 'Twiggy' ],
+ [ 'HTTP::Server::Simple' ],
+ [ 'Coro' ],
+ [ 'Danga::Socket' ],
+ [ 'POE' ],
+ [ 'Starman', ' (workers=10)', workers => 10 ],
+);
-warn "Testing implementations: ", join(", ", @backends), "\n";
+my @backends;
+
+for my $handler (@try) {
+ eval { Plack::Loader->load($handler->[0]) };
+ push @backends, $handler unless $@;
+}
+
+warn "Testing implementations: ", join(", ", map $_->[0], @backends), "\n";
GetOptions(
'a|app=s' => \$app,
@@ -34,14 +50,14 @@ ab: $ab
URL: $url
EOF
- for my $server_class (@backends) {
- run_one($server_class);
+ for my $handler (@backends) {
+ run_one(@$handler);
}
}
sub run_one {
- my $server_class = shift;
- print "-- server: $server_class\n";
+ my($server_class, $how, @args) = @_;
+ print "-- server: $server_class ", ($how || ''), "\n";
test_tcp(
client => sub {
@@ -49,12 +65,13 @@ sub run_one {
my $uri = URI->new($url);
$uri->port($port);
$uri = shell_quote($uri);
+ system "ab -n 20 $uri > /dev/null"; # warmup
print `$ab $uri | grep 'Requests per '`;
},
server => sub {
my $port = shift;
my $handler = Plack::Util::load_psgi $app;
- my $server = Plack::Loader->load($server_class, port => $port);
+ my $server = Plack::Loader->load($server_class, port => $port, @args);
$server->run($handler);
},
);
@@ -672,7 +672,20 @@ sub _load {
sub _load_cpan {
return if $CPAN::VERSION and $CPAN::Config and not @_;
require CPAN;
- if ( $CPAN::HandleConfig::VERSION ) {
+
+ # CPAN-1.82+ adds CPAN::Config::AUTOLOAD to redirect to
+ # CPAN::HandleConfig->load. CPAN reports that the redirection
+ # is deprecated in a warning printed at the user.
+
+ # CPAN-1.81 expects CPAN::HandleConfig->load, does not have
+ # $CPAN::HandleConfig::VERSION but cannot handle
+ # CPAN::Config->load
+
+ # Which "versions expect CPAN::Config->load?
+
+ if ( $CPAN::HandleConfig::VERSION
+ || CPAN::HandleConfig->can('load')
+ ) {
# Newer versions of CPAN have a HandleConfig module
CPAN::HandleConfig->load;
} else {
@@ -802,4 +815,4 @@ END_MAKE
__END__
-#line 1056
+#line 1069
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -4,7 +4,7 @@ package Module::Install::Base;
use strict 'vars';
use vars qw{$VERSION};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
}
# Suspend handler for "redefined" warnings
@@ -9,7 +9,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -7,7 +7,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -34,6 +34,17 @@ sub prompt {
}
}
+# Store a cleaned up version of the MakeMaker version,
+# since we need to behave differently in a variety of
+# ways based on the MM version.
+my $makemaker = eval $ExtUtils::MakeMaker::VERSION;
+
+# If we are passed a param, do a "newer than" comparison.
+# Otherwise, just return the MakeMaker version.
+sub makemaker {
+ ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0
+}
+
sub makemaker_args {
my $self = shift;
my $args = ( $self->{makemaker_args} ||= {} );
@@ -44,7 +55,7 @@ sub makemaker_args {
# For mm args that take multiple space-seperated args,
# append an argument to the current list.
sub makemaker_append {
- my $self = sShift;
+ my $self = shift;
my $name = shift;
my $args = $self->makemaker_args;
$args->{name} = defined $args->{$name}
@@ -130,12 +141,13 @@ sub write {
# an underscore, even though its own version may contain one!
# Hence the funny regexp to get rid of it. See RT #35800
# for details.
- $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
- $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ );
+ my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/;
+ $self->build_requires( 'ExtUtils::MakeMaker' => $v );
+ $self->configure_requires( 'ExtUtils::MakeMaker' => $v );
} else {
# Allow legacy-compatibility with 5.005 by depending on the
# most recent EU:MM that supported 5.005.
- $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
+ $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 );
$self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 );
}
@@ -152,42 +164,62 @@ sub write {
$args->{ABSTRACT} = $self->abstract;
$args->{AUTHOR} = $self->author;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) {
+ if ( $self->makemaker(6.10) ) {
$args->{NO_META} = 1;
}
- if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) {
+ if ( $self->makemaker(6.17) and $self->sign ) {
$args->{SIGN} = 1;
}
unless ( $self->is_admin ) {
delete $args->{SIGN};
}
- # Merge both kinds of requires into prereq_pm
my $prereq = ($args->{PREREQ_PM} ||= {});
%$prereq = ( %$prereq,
- map { @$_ }
+ map { @$_ } # flatten [module => version]
map { @$_ }
grep $_,
- ($self->configure_requires, $self->build_requires, $self->requires)
+ ($self->requires)
);
# Remove any reference to perl, PREREQ_PM doesn't support it
delete $args->{PREREQ_PM}->{perl};
- # merge both kinds of requires into prereq_pm
+ # Merge both kinds of requires into BUILD_REQUIRES
+ my $build_prereq = ($args->{BUILD_REQUIRES} ||= {});
+ %$build_prereq = ( %$build_prereq,
+ map { @$_ } # flatten [module => version]
+ map { @$_ }
+ grep $_,
+ ($self->configure_requires, $self->build_requires)
+ );
+
+ # Remove any reference to perl, BUILD_REQUIRES doesn't support it
+ delete $args->{BUILD_REQUIRES}->{perl};
+
+ # Delete bundled dists from prereq_pm
my $subdirs = ($args->{DIR} ||= []);
if ($self->bundles) {
foreach my $bundle (@{ $self->bundles }) {
my ($file, $dir) = @$bundle;
push @$subdirs, $dir if -d $dir;
- delete $prereq->{$file};
+ delete $build_prereq->{$file}; #Delete from build prereqs only
}
}
+ unless ( $self->makemaker('6.55_03') ) {
+ %$prereq = (%$prereq,%$build_prereq);
+ delete $args->{BUILD_REQUIRES};
+ }
+
if ( my $perl_version = $self->perl_version ) {
eval "use $perl_version; 1"
or die "ERROR: perl: Version $] is installed, "
. "but we need version >= $perl_version";
+
+ if ( $self->makemaker(6.48) ) {
+ $args->{MIN_PERL_VERSION} = $perl_version;
+ }
}
$args->{INSTALLDIRS} = $self->installdirs;
@@ -265,4 +297,4 @@ sub postamble {
__END__
-#line 394
+#line 426
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -230,6 +230,8 @@ sub all_from {
die("The path '$file' does not exist, or is not a file");
}
+ $self->{values}{all_from} = $file;
+
# Some methods pull from POD instead of code.
# If there is a matching .pod, use that instead
my $pod = $file;
@@ -385,11 +387,10 @@ sub name_from {
}
}
-sub perl_version_from {
- my $self = shift;
+sub _extract_perl_version {
if (
- Module::Install::_read($_[0]) =~ m/
- ^
+ $_[0] =~ m/
+ ^\s*
(?:use|require) \s*
v?
([\d_\.]+)
@@ -398,6 +399,16 @@ sub perl_version_from {
) {
my $perl_version = $1;
$perl_version =~ s{_}{}g;
+ return $perl_version;
+ } else {
+ return;
+ }
+}
+
+sub perl_version_from {
+ my $self = shift;
+ my $perl_version=_extract_perl_version(Module::Install::_read($_[0]));
+ if ($perl_version) {
$self->perl_version($perl_version);
} else {
warn "Cannot determine perl version info from $_[0]\n";
@@ -425,13 +436,12 @@ sub author_from {
}
}
-sub license_from {
- my $self = shift;
+sub _extract_license {
if (
- Module::Install::_read($_[0]) =~ m/
+ $_[0] =~ m/
(
=head \d \s+
- (?:licen[cs]e|licensing|copyright|legal)\b
+ (?:licen[cs]e|licensing|copyrights?|legal)\b
.*?
)
(=head\\d.*|=cut.*|)
@@ -439,7 +449,8 @@ sub license_from {
/ixms ) {
my $license_text = $1;
my @phrases = (
- 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1,
+ 'under the same (?:terms|license) as (?:perl|the perl programming language)' => 'perl', 1,
+ 'under the terms of (?:perl|the perl programming language) itself' => 'perl', 1,
'GNU general public license' => 'gpl', 1,
'GNU public license' => 'gpl', 1,
'GNU lesser general public license' => 'lgpl', 1,
@@ -456,20 +467,32 @@ sub license_from {
'proprietary' => 'proprietary', 0,
);
while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) {
- $pattern =~ s{\s+}{\\s+}g;
+ $pattern =~ s#\s+#\\s+#gs;
if ( $license_text =~ /\b$pattern\b/i ) {
- $self->license($license);
- return 1;
+ return $license;
}
}
+ } else {
+ return;
}
+}
- warn "Cannot determine license info from $_[0]\n";
- return 'unknown';
+sub license_from {
+ my $self = shift;
+ if (my $license=_extract_license(Module::Install::_read($_[0]))) {
+ $self->license($license);
+ } else {
+ warn "Cannot determine license info from $_[0]\n";
+ return 'unknown';
+ }
}
sub _extract_bugtracker {
- my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g;
+ my @links = $_[0] =~ m#L<(
+ \Qhttp://rt.cpan.org/\E[^>]+|
+ \Qhttp://github.com/\E[\w_]+/[\w_]+/issues|
+ \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list
+ )>#gx;
my %links;
@links{@links}=();
@links=keys %links;
@@ -485,7 +508,7 @@ sub bugtracker_from {
return 0;
}
if ( @links > 1 ) {
- warn "Found more than on rt.cpan.org link in $_[0]\n";
+ warn "Found more than one bugtracker link in $_[0]\n";
return 0;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -1,29 +0,0 @@
-#line 1
-package Module::Install::TestBase;
-use strict;
-use warnings;
-
-use Module::Install::Base;
-
-use vars qw($VERSION @ISA);
-BEGIN {
- $VERSION = '0.11';
- @ISA = 'Module::Install::Base';
-}
-
-sub use_test_base {
- my $self = shift;
- $self->include('Test::Base');
- $self->include('Test::Base::Filter');
- $self->include('Spiffy');
- $self->include('Test::More');
- $self->include('Test::Builder');
- $self->include('Test::Builder::Module');
- $self->requires('Filter::Util::Call');
-}
-
-1;
-
-=encoding utf8
-
-#line 70
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';
+ $VERSION = '0.92';
@ISA = 'Module::Install::Base';
$ISCORE = 1;
}
@@ -6,7 +6,7 @@ use Module::Install::Base ();
use vars qw{$VERSION @ISA $ISCORE};
BEGIN {
- $VERSION = '0.91';;
+ $VERSION = '0.92';;
@ISA = qw{Module::Install::Base};
$ISCORE = 1;
}
@@ -28,7 +28,7 @@ BEGIN {
# This is not enforced yet, but will be some time in the next few
# releases once we can make sure it won't clash with custom
# Module::Install extensions.
- $VERSION = '0.91';
+ $VERSION = '0.92';
# Storage for the pseudo-singleton
$MAIN = undef;
@@ -348,17 +348,24 @@ sub _caller {
return $call;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _read {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '<', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "< $_[0]" ) or die "open($_[0]): $!";
- }
+ open( FH, '<', $_[0] ) or die "open($_[0]): $!";
+ my $string = do { local $/; <FH> };
+ close FH or die "close($_[0]): $!";
+ return $string;
+}
+END_NEW
+sub _read {
+ local *FH;
+ open( FH, "< $_[0]" ) or die "open($_[0]): $!";
my $string = do { local $/; <FH> };
close FH or die "close($_[0]): $!";
return $string;
}
+END_OLD
sub _readperl {
my $string = Module::Install::_read($_[0]);
@@ -379,18 +386,26 @@ sub _readpod {
return $string;
}
+# Done in evals to avoid confusing Perl::MinimumVersion
+eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@;
sub _write {
local *FH;
- if ( $] >= 5.006 ) {
- open( FH, '>', $_[0] ) or die "open($_[0]): $!";
- } else {
- open( FH, "> $_[0]" ) or die "open($_[0]): $!";
+ open( FH, '>', $_[0] ) or die "open($_[0]): $!";
+ foreach ( 1 .. $#_ ) {
+ print FH $_[$_] or die "print($_[0]): $!";
}
+ close FH or die "close($_[0]): $!";
+}
+END_NEW
+sub _write {
+ local *FH;
+ open( FH, "> $_[0]" ) or die "open($_[0]): $!";
foreach ( 1 .. $#_ ) {
print FH $_[$_] or die "print($_[0]): $!";
}
close FH or die "close($_[0]): $!";
}
+END_OLD
# _version is for processing module versions (eg, 1.03_05) not
# Perl versions (eg, 5.8.1).
@@ -427,4 +442,4 @@ sub _CLASS ($) {
1;
-# Copyright 2008 - 2009 Adam Kennedy.
+# Copyright 2008 - 2010 Adam Kennedy.
@@ -1,539 +0,0 @@
-#line 1
-package Spiffy;
-use strict;
-use 5.006001;
-use warnings;
-use Carp;
-require Exporter;
-our $VERSION = '0.30';
-our @EXPORT = ();
-our @EXPORT_BASE = qw(field const stub super);
-our @EXPORT_OK = (@EXPORT_BASE, qw(id WWW XXX YYY ZZZ));
-our %EXPORT_TAGS = (XXX => [qw(WWW XXX YYY ZZZ)]);
-
-my $stack_frame = 0;
-my $dump = 'yaml';
-my $bases_map = {};
-
-sub WWW; sub XXX; sub YYY; sub ZZZ;
-
-# This line is here to convince "autouse" into believing we are autousable.
-sub can {
- ($_[1] eq 'import' and caller()->isa('autouse'))
- ? \&Exporter::import # pacify autouse's equality test
- : $_[0]->SUPER::can($_[1]) # normal case
-}
-
-# TODO
-#
-# Exported functions like field and super should be hidden so as not to
-# be confused with methods that can be inherited.
-#
-
-sub new {
- my $class = shift;
- $class = ref($class) || $class;
- my $self = bless {}, $class;
- while (@_) {
- my $method = shift;
- $self->$method(shift);
- }
- return $self;
-}
-
-my $filtered_files = {};
-my $filter_dump = 0;
-my $filter_save = 0;
-our $filter_result = '';
-sub import {
- no strict 'refs';
- no warnings;
- my $self_package = shift;
-
- # XXX Using parse_arguments here might cause confusion, because the
- # subclass's boolean_arguments and paired_arguments can conflict, causing
- # difficult debugging. Consider using something truly local.
- my ($args, @export_list) = do {
- local *boolean_arguments = sub {
- qw(
- -base -Base -mixin -selfless
- -XXX -dumper -yaml
- -filter_dump -filter_save
- )
- };
- local *paired_arguments = sub { qw(-package) };
- $self_package->parse_arguments(@_);
- };
- return spiffy_mixin_import(scalar(caller(0)), $self_package, @export_list)
- if $args->{-mixin};
-
- $filter_dump = 1 if $args->{-filter_dump};
- $filter_save = 1 if $args->{-filter_save};
- $dump = 'yaml' if $args->{-yaml};
- $dump = 'dumper' if $args->{-dumper};
-
- local @EXPORT_BASE = @EXPORT_BASE;
-
- if ($args->{-XXX}) {
- push @EXPORT_BASE, @{$EXPORT_TAGS{XXX}}
- unless grep /^XXX$/, @EXPORT_BASE;
- }
-
- spiffy_filter()
- if ($args->{-selfless} or $args->{-Base}) and
- not $filtered_files->{(caller($stack_frame))[1]}++;
-
- my $caller_package = $args->{-package} || caller($stack_frame);
- push @{"$caller_package\::ISA"}, $self_package
- if $args->{-Base} or $args->{-base};
-
- for my $class (@{all_my_bases($self_package)}) {
- next unless $class->isa('Spiffy');
- my @export = grep {
- not defined &{"$caller_package\::$_"};
- } ( @{"$class\::EXPORT"},
- ($args->{-Base} or $args->{-base})
- ? @{"$class\::EXPORT_BASE"} : (),
- );
- my @export_ok = grep {
- not defined &{"$caller_package\::$_"};
- } @{"$class\::EXPORT_OK"};
-
- # Avoid calling the expensive Exporter::export
- # if there is nothing to do (optimization)
- my %exportable = map { ($_, 1) } @export, @export_ok;
- next unless keys %exportable;
-
- my @export_save = @{"$class\::EXPORT"};
- my @export_ok_save = @{"$class\::EXPORT_OK"};
- @{"$class\::EXPORT"} = @export;
- @{"$class\::EXPORT_OK"} = @export_ok;
- my @list = grep {
- (my $v = $_) =~ s/^[\!\:]//;
- $exportable{$v} or ${"$class\::EXPORT_TAGS"}{$v};
- } @export_list;
- Exporter::export($class, $caller_package, @list);
- @{"$class\::EXPORT"} = @export_save;
- @{"$class\::EXPORT_OK"} = @export_ok_save;
- }
-}
-
-sub spiffy_filter {
- require Filter::Util::Call;
- my $done = 0;
- Filter::Util::Call::filter_add(
- sub {
- return 0 if $done;
- my ($data, $end) = ('', '');
- while (my $status = Filter::Util::Call::filter_read()) {
- return $status if $status < 0;
- if (/^__(?:END|DATA)__\r?$/) {
- $end = $_;
- last;
- }
- $data .= $_;
- $_ = '';
- }
- $_ = $data;
- my @my_subs;
- s[^(sub\s+\w+\s+\{)(.*\n)]
- [${1}my \$self = shift;$2]gm;
- s[^(sub\s+\w+)\s*\(\s*\)(\s+\{.*\n)]
- [${1}${2}]gm;
- s[^my\s+sub\s+(\w+)(\s+\{)(.*)((?s:.*?\n))\}\n]
- [push @my_subs, $1; "\$$1 = sub$2my \$self = shift;$3$4\};\n"]gem;
- my $preclare = '';
- if (@my_subs) {
- $preclare = join ',', map "\$$_", @my_subs;
- $preclare = "my($preclare);";
- }
- $_ = "use strict;use warnings;$preclare${_};1;\n$end";
- if ($filter_dump) { print; exit }
- if ($filter_save) { $filter_result = $_; $_ = $filter_result; }
- $done = 1;
- }
- );
-}
-
-sub base {
- push @_, -base;
- goto &import;
-}
-
-sub all_my_bases {
- my $class = shift;
-
- return $bases_map->{$class}
- if defined $bases_map->{$class};
-
- my @bases = ($class);
- no strict 'refs';
- for my $base_class (@{"${class}::ISA"}) {
- push @bases, @{all_my_bases($base_class)};
- }
- my $used = {};
- $bases_map->{$class} = [grep {not $used->{$_}++} @bases];
-}
-
-my %code = (
- sub_start =>
- "sub {\n",
- set_default =>
- " \$_[0]->{%s} = %s\n unless exists \$_[0]->{%s};\n",
- init =>
- " return \$_[0]->{%s} = do { my \$self = \$_[0]; %s }\n" .
- " unless \$#_ > 0 or defined \$_[0]->{%s};\n",
- weak_init =>
- " return do {\n" .
- " \$_[0]->{%s} = do { my \$self = \$_[0]; %s };\n" .
- " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n" .
- " \$_[0]->{%s};\n" .
- " } unless \$#_ > 0 or defined \$_[0]->{%s};\n",
- return_if_get =>
- " return \$_[0]->{%s} unless \$#_ > 0;\n",
- set =>
- " \$_[0]->{%s} = \$_[1];\n",
- weaken =>
- " Scalar::Util::weaken(\$_[0]->{%s}) if ref \$_[0]->{%s};\n",
- sub_end =>
- " return \$_[0]->{%s};\n}\n",
-);
-
-sub field {
- my $package = caller;
- my ($args, @values) = do {
- no warnings;
- local *boolean_arguments = sub { (qw(-weak)) };
- local *paired_arguments = sub { (qw(-package -init)) };
- Spiffy->parse_arguments(@_);
- };
- my ($field, $default) = @values;
- $package = $args->{-package} if defined $args->{-package};
- die "Cannot have a default for a weakened field ($field)"
- if defined $default && $args->{-weak};
- return if defined &{"${package}::$field"};
- require Scalar::Util if $args->{-weak};
- my $default_string =
- ( ref($default) eq 'ARRAY' and not @$default )
- ? '[]'
- : (ref($default) eq 'HASH' and not keys %$default )
- ? '{}'
- : default_as_code($default);
-
- my $code = $code{sub_start};
- if ($args->{-init}) {
- my $fragment = $args->{-weak} ? $code{weak_init} : $code{init};
- $code .= sprintf $fragment, $field, $args->{-init}, ($field) x 4;
- }
- $code .= sprintf $code{set_default}, $field, $default_string, $field
- if defined $default;
- $code .= sprintf $code{return_if_get}, $field;
- $code .= sprintf $code{set}, $field;
- $code .= sprintf $code{weaken}, $field, $field
- if $args->{-weak};
- $code .= sprintf $code{sub_end}, $field;
-
- my $sub = eval $code;
- die $@ if $@;
- no strict 'refs';
- *{"${package}::$field"} = $sub;
- return $code if defined wantarray;
-}
-
-sub default_as_code {
- require Data::Dumper;
- local $Data::Dumper::Sortkeys = 1;
- my $code = Data::Dumper::Dumper(shift);
- $code =~ s/^\$VAR1 = //;
- $code =~ s/;$//;
- return $code;
-}
-
-sub const {
- my $package = caller;
- my ($args, @values) = do {
- no warnings;
- local *paired_arguments = sub { (qw(-package)) };
- Spiffy->parse_arguments(@_);
- };
- my ($field, $default) = @values;
- $package = $args->{-package} if defined $args->{-package};
- no strict 'refs';
- return if defined &{"${package}::$field"};
- *{"${package}::$field"} = sub { $default }
-}
-
-sub stub {
- my $package = caller;
- my ($args, @values) = do {
- no warnings;
- local *paired_arguments = sub { (qw(-package)) };
- Spiffy->parse_arguments(@_);
- };
- my ($field, $default) = @values;
- $package = $args->{-package} if defined $args->{-package};
- no strict 'refs';
- return if defined &{"${package}::$field"};
- *{"${package}::$field"} =
- sub {
- require Carp;
- Carp::confess
- "Method $field in package $package must be subclassed";
- }
-}
-
-sub parse_arguments {
- my $class = shift;
- my ($args, @values) = ({}, ());
- my %booleans = map { ($_, 1) } $class->boolean_arguments;
- my %pairs = map { ($_, 1) } $class->paired_arguments;
- while (@_) {
- my $elem = shift;
- if (defined $elem and defined $booleans{$elem}) {
- $args->{$elem} = (@_ and $_[0] =~ /^[01]$/)
- ? shift
- : 1;
- }
- elsif (defined $elem and defined $pairs{$elem} and @_) {
- $args->{$elem} = shift;
- }
- else {
- push @values, $elem;
- }
- }
- return wantarray ? ($args, @values) : $args;
-}
-
-sub boolean_arguments { () }
-sub paired_arguments { () }
-
-# get a unique id for any node
-sub id {
- if (not ref $_[0]) {
- return 'undef' if not defined $_[0];
- \$_[0] =~ /\((\w+)\)$/o or die;
- return "$1-S";
- }
- require overload;
- overload::StrVal($_[0]) =~ /\((\w+)\)$/o or die;
- return $1;
-}
-
-#===============================================================================
-# It's super, man.
-#===============================================================================
-package DB;
-{
- no warnings 'redefine';
- sub super_args {
- my @dummy = caller(@_ ? $_[0] : 2);
- return @DB::args;
- }
-}
-
-package Spiffy;
-sub super {
- my $method;
- my $frame = 1;
- while ($method = (caller($frame++))[3]) {
- $method =~ s/.*::// and last;
- }
- my @args = DB::super_args($frame);
- @_ = @_ ? ($args[0], @_) : @args;
- my $class = ref $_[0] ? ref $_[0] : $_[0];
- my $caller_class = caller;
- my $seen = 0;
- my @super_classes = reverse grep {
- ($seen or $seen = ($_ eq $caller_class)) ? 0 : 1;
- } reverse @{all_my_bases($class)};
- for my $super_class (@super_classes) {
- no strict 'refs';
- next if $super_class eq $class;
- if (defined &{"${super_class}::$method"}) {
- ${"$super_class\::AUTOLOAD"} = ${"$class\::AUTOLOAD"}
- if $method eq 'AUTOLOAD';
- return &{"${super_class}::$method"};
- }
- }
- return;
-}
-
-#===============================================================================
-# This code deserves a spanking, because it is being very naughty.
-# It is exchanging base.pm's import() for its own, so that people
-# can use base.pm with Spiffy modules, without being the wiser.
-#===============================================================================
-my $real_base_import;
-my $real_mixin_import;
-
-BEGIN {
- require base unless defined $INC{'base.pm'};
- $INC{'mixin.pm'} ||= 'Spiffy/mixin.pm';
- $real_base_import = \&base::import;
- $real_mixin_import = \&mixin::import;
- no warnings;
- *base::import = \&spiffy_base_import;
- *mixin::import = \&spiffy_mixin_import;
-}
-
-# my $i = 0;
-# while (my $caller = caller($i++)) {
-# next unless $caller eq 'base' or $caller eq 'mixin';
-# croak <<END;
-# Spiffy.pm must be loaded before calling 'use base' or 'use mixin' with a
-# Spiffy module. See the documentation of Spiffy.pm for details.
-# END
-# }
-
-sub spiffy_base_import {
- my @base_classes = @_;
- shift @base_classes;
- no strict 'refs';
- goto &$real_base_import
- unless grep {
- eval "require $_" unless %{"$_\::"};
- $_->isa('Spiffy');
- } @base_classes;
- my $inheritor = caller(0);
- for my $base_class (@base_classes) {
- next if $inheritor->isa($base_class);
- croak "Can't mix Spiffy and non-Spiffy classes in 'use base'.\n",
- "See the documentation of Spiffy.pm for details\n "
- unless $base_class->isa('Spiffy');
- $stack_frame = 1; # tell import to use different caller
- import($base_class, '-base');
- $stack_frame = 0;
- }
-}
-
-sub mixin {
- my $self = shift;
- my $target_class = ref($self);
- spiffy_mixin_import($target_class, @_)
-}
-
-sub spiffy_mixin_import {
- my $target_class = shift;
- $target_class = caller(0)
- if $target_class eq 'mixin';
- my $mixin_class = shift
- or die "Nothing to mixin";
- eval "require $mixin_class";
- my @roles = @_;
- my $pseudo_class = join '-', $target_class, $mixin_class, @roles;
- my %methods = spiffy_mixin_methods($mixin_class, @roles);
- no strict 'refs';
- no warnings;
- @{"$pseudo_class\::ISA"} = @{"$target_class\::ISA"};
- @{"$target_class\::ISA"} = ($pseudo_class);
- for (keys %methods) {
- *{"$pseudo_class\::$_"} = $methods{$_};
- }
-}
-
-sub spiffy_mixin_methods {
- my $mixin_class = shift;
- no strict 'refs';
- my %methods = spiffy_all_methods($mixin_class);
- map {
- $methods{$_}
- ? ($_, \ &{"$methods{$_}\::$_"})
- : ($_, \ &{"$mixin_class\::$_"})
- } @_
- ? (get_roles($mixin_class, @_))
- : (keys %methods);
-}
-
-sub get_roles {
- my $mixin_class = shift;
- my @roles = @_;
- while (grep /^!*:/, @roles) {
- @roles = map {
- s/!!//g;
- /^!:(.*)/ ? do {
- my $m = "_role_$1";
- map("!$_", $mixin_class->$m);
- } :
- /^:(.*)/ ? do {
- my $m = "_role_$1";
- ($mixin_class->$m);
- } :
- ($_)
- } @roles;
- }
- if (@roles and $roles[0] =~ /^!/) {
- my %methods = spiffy_all_methods($mixin_class);
- unshift @roles, keys(%methods);
- }
- my %roles;
- for (@roles) {
- s/!!//g;
- delete $roles{$1}, next
- if /^!(.*)/;
- $roles{$_} = 1;
- }
- keys %roles;
-}
-
-sub spiffy_all_methods {
- no strict 'refs';
- my $class = shift;
- return if $class eq 'Spiffy';
- my %methods = map {
- ($_, $class)
- } grep {
- defined &{"$class\::$_"} and not /^_/
- } keys %{"$class\::"};
- my %super_methods;
- %super_methods = spiffy_all_methods(${"$class\::ISA"}[0])
- if @{"$class\::ISA"};
- %{{%super_methods, %methods}};
-}
-
-
-# END of naughty code.
-#===============================================================================
-# Debugging support
-#===============================================================================
-sub spiffy_dump {
- no warnings;
- if ($dump eq 'dumper') {
- require Data::Dumper;
- $Data::Dumper::Sortkeys = 1;
- $Data::Dumper::Indent = 1;
- return Data::Dumper::Dumper(@_);
- }
- require YAML;
- $YAML::UseVersion = 0;
- return YAML::Dump(@_) . "...\n";
-}
-
-sub at_line_number {
- my ($file_path, $line_number) = (caller(1))[1,2];
- " at $file_path line $line_number\n";
-}
-
-sub WWW {
- warn spiffy_dump(@_) . at_line_number;
- return wantarray ? @_ : $_[0];
-}
-
-sub XXX {
- die spiffy_dump(@_) . at_line_number;
-}
-
-sub YYY {
- print spiffy_dump(@_) . at_line_number;
- return wantarray ? @_ : $_[0];
-}
-
-sub ZZZ {
- require Carp;
- Carp::confess spiffy_dump(@_);
-}
-
-1;
-
-__END__
-
-#line 1066
@@ -1,344 +0,0 @@
-#line 1
-#. TODO:
-#.
-
-#===============================================================================
-# This is the default class for handling Test::Base data filtering.
-#===============================================================================
-package Test::Base::Filter;
-use Spiffy -Base;
-use Spiffy ':XXX';
-
-field 'current_block';
-
-our $arguments;
-sub current_arguments {
- return undef unless defined $arguments;
- my $args = $arguments;
- $args =~ s/(\\s)/ /g;
- $args =~ s/(\\[a-z])/'"' . $1 . '"'/gee;
- return $args;
-}
-
-sub assert_scalar {
- return if @_ == 1;
- require Carp;
- my $filter = (caller(1))[3];
- $filter =~ s/.*:://;
- Carp::croak "Input to the '$filter' filter must be a scalar, not a list";
-}
-
-sub _apply_deepest {
- my $method = shift;
- return () unless @_;
- if (ref $_[0] eq 'ARRAY') {
- for my $aref (@_) {
- @$aref = $self->_apply_deepest($method, @$aref);
- }
- return @_;
- }
- $self->$method(@_);
-}
-
-sub _split_array {
- map {
- [$self->split($_)];
- } @_;
-}
-
-sub _peel_deepest {
- return () unless @_;
- if (ref $_[0] eq 'ARRAY') {
- if (ref $_[0]->[0] eq 'ARRAY') {
- for my $aref (@_) {
- @$aref = $self->_peel_deepest(@$aref);
- }
- return @_;
- }
- return map { $_->[0] } @_;
- }
- return @_;
-}
-
-#===============================================================================
-# these filters work on the leaves of nested arrays
-#===============================================================================
-sub Join { $self->_peel_deepest($self->_apply_deepest(join => @_)) }
-sub Reverse { $self->_apply_deepest(reverse => @_) }
-sub Split { $self->_apply_deepest(_split_array => @_) }
-sub Sort { $self->_apply_deepest(sort => @_) }
-
-
-sub append {
- my $suffix = $self->current_arguments;
- map { $_ . $suffix } @_;
-}
-
-sub array {
- return [@_];
-}
-
-sub base64_decode {
- $self->assert_scalar(@_);
- require MIME::Base64;
- MIME::Base64::decode_base64(shift);
-}
-
-sub base64_encode {
- $self->assert_scalar(@_);
- require MIME::Base64;
- MIME::Base64::encode_base64(shift);
-}
-
-sub chomp {
- map { CORE::chomp; $_ } @_;
-}
-
-sub chop {
- map { CORE::chop; $_ } @_;
-}
-
-sub dumper {
- no warnings 'once';
- require Data::Dumper;
- local $Data::Dumper::Sortkeys = 1;
- local $Data::Dumper::Indent = 1;
- local $Data::Dumper::Terse = 1;
- Data::Dumper::Dumper(@_);
-}
-
-sub escape {
- $self->assert_scalar(@_);
- my $text = shift;
- $text =~ s/(\\.)/eval "qq{$1}"/ge;
- return $text;
-}
-
-sub eval {
- $self->assert_scalar(@_);
- my @return = CORE::eval(shift);
- return $@ if $@;
- return @return;
-}
-
-sub eval_all {
- $self->assert_scalar(@_);
- my $out = '';
- my $err = '';
- Test::Base::tie_output(*STDOUT, $out);
- Test::Base::tie_output(*STDERR, $err);
- my $return = CORE::eval(shift);
- no warnings;
- untie *STDOUT;
- untie *STDERR;
- return $return, $@, $out, $err;
-}
-
-sub eval_stderr {
- $self->assert_scalar(@_);
- my $output = '';
- Test::Base::tie_output(*STDERR, $output);
- CORE::eval(shift);
- no warnings;
- untie *STDERR;
- return $output;
-}
-
-sub eval_stdout {
- $self->assert_scalar(@_);
- my $output = '';
- Test::Base::tie_output(*STDOUT, $output);
- CORE::eval(shift);
- no warnings;
- untie *STDOUT;
- return $output;
-}
-
-sub exec_perl_stdout {
- my $tmpfile = "/tmp/test-blocks-$$";
- $self->_write_to($tmpfile, @_);
- open my $execution, "$^X $tmpfile 2>&1 |"
- or die "Couldn't open subprocess: $!\n";
- local $/;
- my $output = <$execution>;
- close $execution;
- unlink($tmpfile)
- or die "Couldn't unlink $tmpfile: $!\n";
- return $output;
-}
-
-sub flatten {
- $self->assert_scalar(@_);
- my $ref = shift;
- if (ref($ref) eq 'HASH') {
- return map {
- ($_, $ref->{$_});
- } sort keys %$ref;
- }
- if (ref($ref) eq 'ARRAY') {
- return @$ref;
- }
- die "Can only flatten a hash or array ref";
-}
-
-sub get_url {
- $self->assert_scalar(@_);
- my $url = shift;
- CORE::chomp($url);
- require LWP::Simple;
- LWP::Simple::get($url);
-}
-
-sub hash {
- return +{ @_ };
-}
-
-sub head {
- my $size = $self->current_arguments || 1;
- return splice(@_, 0, $size);
-}
-
-sub join {
- my $string = $self->current_arguments;
- $string = '' unless defined $string;
- CORE::join $string, @_;
-}
-
-sub lines {
- $self->assert_scalar(@_);
- my $text = shift;
- return () unless length $text;
- my @lines = ($text =~ /^(.*\n?)/gm);
- return @lines;
-}
-
-sub norm {
- $self->assert_scalar(@_);
- my $text = shift;
- $text = '' unless defined $text;
- $text =~ s/\015\012/\n/g;
- $text =~ s/\r/\n/g;
- return $text;
-}
-
-sub prepend {
- my $prefix = $self->current_arguments;
- map { $prefix . $_ } @_;
-}
-
-sub read_file {
- $self->assert_scalar(@_);
- my $file = shift;
- CORE::chomp $file;
- open my $fh, $file
- or die "Can't open '$file' for input:\n$!";
- CORE::join '', <$fh>;
-}
-
-sub regexp {
- $self->assert_scalar(@_);
- my $text = shift;
- my $flags = $self->current_arguments;
- if ($text =~ /\n.*?\n/s) {
- $flags = 'xism'
- unless defined $flags;
- }
- else {
- CORE::chomp($text);
- }
- $flags ||= '';
- my $regexp = eval "qr{$text}$flags";
- die $@ if $@;
- return $regexp;
-}
-
-sub reverse {
- CORE::reverse(@_);
-}
-
-sub slice {
- die "Invalid args for slice"
- unless $self->current_arguments =~ /^(\d+)(?:,(\d))?$/;
- my ($x, $y) = ($1, $2);
- $y = $x if not defined $y;
- die "Invalid args for slice"
- if $x > $y;
- return splice(@_, $x, 1 + $y - $x);
-}
-
-sub sort {
- CORE::sort(@_);
-}
-
-sub split {
- $self->assert_scalar(@_);
- my $separator = $self->current_arguments;
- if (defined $separator and $separator =~ s{^/(.*)/$}{$1}) {
- my $regexp = $1;
- $separator = qr{$regexp};
- }
- $separator = qr/\s+/ unless $separator;
- CORE::split $separator, shift;
-}
-
-sub strict {
- $self->assert_scalar(@_);
- <<'...' . shift;
-use strict;
-use warnings;
-...
-}
-
-sub tail {
- my $size = $self->current_arguments || 1;
- return splice(@_, @_ - $size, $size);
-}
-
-sub trim {
- map {
- s/\A([ \t]*\n)+//;
- s/(?<=\n)\s*\z//g;
- $_;
- } @_;
-}
-
-sub unchomp {
- map { $_ . "\n" } @_;
-}
-
-sub write_file {
- my $file = $self->current_arguments
- or die "No file specified for write_file filter";
- if ($file =~ /(.*)[\\\/]/) {
- my $dir = $1;
- if (not -e $dir) {
- require File::Path;
- File::Path::mkpath($dir)
- or die "Can't create $dir";
- }
- }
- open my $fh, ">$file"
- or die "Can't open '$file' for output\n:$!";
- print $fh @_;
- close $fh;
- return $file;
-}
-
-sub yaml {
- $self->assert_scalar(@_);
- require YAML;
- return YAML::Load(shift);
-}
-
-sub _write_to {
- my $filename = shift;
- open my $script, ">$filename"
- or die "Couldn't open $filename: $!\n";
- print $script @_;
- close $script
- or die "Couldn't close $filename: $!\n";
-}
-
-__DATA__
-
-#line 639
@@ -1,684 +0,0 @@
-#line 1
-# TODO:
-#
-package Test::Base;
-use 5.006001;
-use Spiffy 0.30 -Base;
-use Spiffy ':XXX';
-our $VERSION = '0.59';
-
-my @test_more_exports;
-BEGIN {
- @test_more_exports = qw(
- ok isnt like unlike is_deeply cmp_ok
- skip todo_skip pass fail
- eq_array eq_hash eq_set
- plan can_ok isa_ok diag
- use_ok
- $TODO
- );
-}
-
-use Test::More import => \@test_more_exports;
-use Carp;
-
-our @EXPORT = (@test_more_exports, qw(
- is no_diff
-
- blocks next_block first_block
- delimiters spec_file spec_string
- filters filters_delay filter_arguments
- run run_compare run_is run_is_deeply run_like run_unlike
- skip_all_unless_require is_deep run_is_deep
- WWW XXX YYY ZZZ
- tie_output no_diag_on_only
-
- find_my_self default_object
-
- croak carp cluck confess
-));
-
-field '_spec_file';
-field '_spec_string';
-field _filters => [qw(norm trim)];
-field _filters_map => {};
-field spec =>
- -init => '$self->_spec_init';
-field block_list =>
- -init => '$self->_block_list_init';
-field _next_list => [];
-field block_delim =>
- -init => '$self->block_delim_default';
-field data_delim =>
- -init => '$self->data_delim_default';
-field _filters_delay => 0;
-field _no_diag_on_only => 0;
-
-field block_delim_default => '===';
-field data_delim_default => '---';
-
-my $default_class;
-my $default_object;
-my $reserved_section_names = {};
-
-sub default_object {
- $default_object ||= $default_class->new;
- return $default_object;
-}
-
-my $import_called = 0;
-sub import() {
- $import_called = 1;
- my $class = (grep /^-base$/i, @_)
- ? scalar(caller)
- : $_[0];
- if (not defined $default_class) {
- $default_class = $class;
- }
-# else {
-# croak "Can't use $class after using $default_class"
-# unless $default_class->isa($class);
-# }
-
- unless (grep /^-base$/i, @_) {
- my @args;
- for (my $ii = 1; $ii <= $#_; ++$ii) {
- if ($_[$ii] eq '-package') {
- ++$ii;
- } else {
- push @args, $_[$ii];
- }
- }
- Test::More->import(import => \@test_more_exports, @args)
- if @args;
- }
-
- _strict_warnings();
- goto &Spiffy::import;
-}
-
-# Wrap Test::Builder::plan
-my $plan_code = \&Test::Builder::plan;
-my $Have_Plan = 0;
-{
- no warnings 'redefine';
- *Test::Builder::plan = sub {
- $Have_Plan = 1;
- goto &$plan_code;
- };
-}
-
-my $DIED = 0;
-$SIG{__DIE__} = sub { $DIED = 1; die @_ };
-
-sub block_class { $self->find_class('Block') }
-sub filter_class { $self->find_class('Filter') }
-
-sub find_class {
- my $suffix = shift;
- my $class = ref($self) . "::$suffix";
- return $class if $class->can('new');
- $class = __PACKAGE__ . "::$suffix";
- return $class if $class->can('new');
- eval "require $class";
- return $class if $class->can('new');
- die "Can't find a class for $suffix";
-}
-
-sub check_late {
- if ($self->{block_list}) {
- my $caller = (caller(1))[3];
- $caller =~ s/.*:://;
- croak "Too late to call $caller()"
- }
-}
-
-sub find_my_self() {
- my $self = ref($_[0]) eq $default_class
- ? splice(@_, 0, 1)
- : default_object();
- return $self, @_;
-}
-
-sub blocks() {
- (my ($self), @_) = find_my_self(@_);
-
- croak "Invalid arguments passed to 'blocks'"
- if @_ > 1;
- croak sprintf("'%s' is invalid argument to blocks()", shift(@_))
- if @_ && $_[0] !~ /^[a-zA-Z]\w*$/;
-
- my $blocks = $self->block_list;
-
- my $section_name = shift || '';
- my @blocks = $section_name
- ? (grep { exists $_->{$section_name} } @$blocks)
- : (@$blocks);
-
- return scalar(@blocks) unless wantarray;
-
- return (@blocks) if $self->_filters_delay;
-
- for my $block (@blocks) {
- $block->run_filters
- unless $block->is_filtered;
- }
-
- return (@blocks);
-}
-
-sub next_block() {
- (my ($self), @_) = find_my_self(@_);
- my $list = $self->_next_list;
- if (@$list == 0) {
- $list = [@{$self->block_list}, undef];
- $self->_next_list($list);
- }
- my $block = shift @$list;
- if (defined $block and not $block->is_filtered) {
- $block->run_filters;
- }
- return $block;
-}
-
-sub first_block() {
- (my ($self), @_) = find_my_self(@_);
- $self->_next_list([]);
- $self->next_block;
-}
-
-sub filters_delay() {
- (my ($self), @_) = find_my_self(@_);
- $self->_filters_delay(defined $_[0] ? shift : 1);
-}
-
-sub no_diag_on_only() {
- (my ($self), @_) = find_my_self(@_);
- $self->_no_diag_on_only(defined $_[0] ? shift : 1);
-}
-
-sub delimiters() {
- (my ($self), @_) = find_my_self(@_);
- $self->check_late;
- my ($block_delimiter, $data_delimiter) = @_;
- $block_delimiter ||= $self->block_delim_default;
- $data_delimiter ||= $self->data_delim_default;
- $self->block_delim($block_delimiter);
- $self->data_delim($data_delimiter);
- return $self;
-}
-
-sub spec_file() {
- (my ($self), @_) = find_my_self(@_);
- $self->check_late;
- $self->_spec_file(shift);
- return $self;
-}
-
-sub spec_string() {
- (my ($self), @_) = find_my_self(@_);
- $self->check_late;
- $self->_spec_string(shift);
- return $self;
-}
-
-sub filters() {
- (my ($self), @_) = find_my_self(@_);
- if (ref($_[0]) eq 'HASH') {
- $self->_filters_map(shift);
- }
- else {
- my $filters = $self->_filters;
- push @$filters, @_;
- }
- return $self;
-}
-
-sub filter_arguments() {
- $Test::Base::Filter::arguments;
-}
-
-sub have_text_diff {
- eval { require Text::Diff; 1 } &&
- $Text::Diff::VERSION >= 0.35 &&
- $Algorithm::Diff::VERSION >= 1.15;
-}
-
-sub is($$;$) {
- (my ($self), @_) = find_my_self(@_);
- my ($actual, $expected, $name) = @_;
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- if ($ENV{TEST_SHOW_NO_DIFFS} or
- not defined $actual or
- not defined $expected or
- $actual eq $expected or
- not($self->have_text_diff) or
- $expected !~ /\n./s
- ) {
- Test::More::is($actual, $expected, $name);
- }
- else {
- $name = '' unless defined $name;
- ok $actual eq $expected,
- $name . "\n" . Text::Diff::diff(\$expected, \$actual);
- }
-}
-
-sub run(&;$) {
- (my ($self), @_) = find_my_self(@_);
- my $callback = shift;
- for my $block (@{$self->block_list}) {
- $block->run_filters unless $block->is_filtered;
- &{$callback}($block);
- }
-}
-
-my $name_error = "Can't determine section names";
-sub _section_names {
- return @_ if @_ == 2;
- my $block = $self->first_block
- or croak $name_error;
- my @names = grep {
- $_ !~ /^(ONLY|LAST|SKIP)$/;
- } @{$block->{_section_order}[0] || []};
- croak "$name_error. Need two sections in first block"
- unless @names == 2;
- return @names;
-}
-
-sub _assert_plan {
- plan('no_plan') unless $Have_Plan;
-}
-
-sub END {
- run_compare() unless $Have_Plan or $DIED or not $import_called;
-}
-
-sub run_compare() {
- (my ($self), @_) = find_my_self(@_);
- $self->_assert_plan;
- my ($x, $y) = $self->_section_names(@_);
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- for my $block (@{$self->block_list}) {
- next unless exists($block->{$x}) and exists($block->{$y});
- $block->run_filters unless $block->is_filtered;
- if (ref $block->$x) {
- is_deeply($block->$x, $block->$y,
- $block->name ? $block->name : ());
- }
- elsif (ref $block->$y eq 'Regexp') {
- my $regexp = ref $y ? $y : $block->$y;
- like($block->$x, $regexp, $block->name ? $block->name : ());
- }
- else {
- is($block->$x, $block->$y, $block->name ? $block->name : ());
- }
- }
-}
-
-sub run_is() {
- (my ($self), @_) = find_my_self(@_);
- $self->_assert_plan;
- my ($x, $y) = $self->_section_names(@_);
- local $Test::Builder::Level = $Test::Builder::Level + 1;
- for my $block (@{$self->block_list}) {
- next unless exists($block->{$x}) and exists($block->{$y});
- $block->run_filters unless $block->is_filtered;
- is($block->$x, $block->$y,
- $block->name ? $block->name : ()
- );
- }
-}
-
-sub run_is_deeply() {
- (my ($self), @_) = find_my_self(@_);
- $self->_assert_plan;
- my ($x, $y) = $self->_section_names(@_);
- for my $block (@{$self->block_list}) {
- next unless exists($block->{$x}) and exists($block->{$y});
- $block->run_filters unless $block->is_filtered;
- is_deeply($block->$x, $block->$y,
- $block->name ? $block->name : ()
- );
- }
-}
-
-sub run_like() {
- (my ($self), @_) = find_my_self(@_);
- $self->_assert_plan;
- my ($x, $y) = $self->_section_names(@_);
- for my $block (@{$self->block_list}) {
- next unless exists($block->{$x}) and defined($y);
- $block->run_filters unless $block->is_filtered;
- my $regexp = ref $y ? $y : $block->$y;
- like($block->$x, $regexp,
- $block->name ? $block->name : ()
- );
- }
-}
-
-sub run_unlike() {
- (my ($self), @_) = find_my_self(@_);
- $self->_assert_plan;
- my ($x, $y) = $self->_section_names(@_);
- for my $block (@{$self->block_list}) {
- next unless exists($block->{$x}) and defined($y);
- $block->run_filters unless $block->is_filtered;
- my $regexp = ref $y ? $y : $block->$y;
- unlike($block->$x, $regexp,
- $block->name ? $block->name : ()
- );
- }
-}
-
-sub skip_all_unless_require() {
- (my ($self), @_) = find_my_self(@_);
- my $module = shift;
- eval "require $module; 1"
- or Test::More::plan(
- skip_all => "$module failed to load"
- );
-}
-
-sub is_deep() {
- (my ($self), @_) = find_my_self(@_);
- require Test::Deep;
- Test::Deep::cmp_deeply(@_);
-}
-
-sub run_is_deep() {
- (my ($self), @_) = find_my_self(@_);
- $self->_assert_plan;
- my ($x, $y) = $self->_section_names(@_);
- for my $block (@{$self->block_list}) {
- next unless exists($block->{$x}) and exists($block->{$y});
- $block->run_filters unless $block->is_filtered;
- is_deep($block->$x, $block->$y,
- $block->name ? $block->name : ()
- );
- }
-}
-
-sub _pre_eval {
- my $spec = shift;
- return $spec unless $spec =~
- s/\A\s*<<<(.*?)>>>\s*$//sm;
- my $eval_code = $1;
- eval "package main; $eval_code";
- croak $@ if $@;
- return $spec;
-}
-
-sub _block_list_init {
- my $spec = $self->spec;
- $spec = $self->_pre_eval($spec);
- my $cd = $self->block_delim;
- my @hunks = ($spec =~ /^(\Q${cd}\E.*?(?=^\Q${cd}\E|\z))/msg);
- my $blocks = $self->_choose_blocks(@hunks);
- $self->block_list($blocks); # Need to set early for possible filter use
- my $seq = 1;
- for my $block (@$blocks) {
- $block->blocks_object($self);
- $block->seq_num($seq++);
- }
- return $blocks;
-}
-
-sub _choose_blocks {
- my $blocks = [];
- for my $hunk (@_) {
- my $block = $self->_make_block($hunk);
- if (exists $block->{ONLY}) {
- diag "I found ONLY: maybe you're debugging?"
- unless $self->_no_diag_on_only;
- return [$block];
- }
- next if exists $block->{SKIP};
- push @$blocks, $block;
- if (exists $block->{LAST}) {
- return $blocks;
- }
- }
- return $blocks;
-}
-
-sub _check_reserved {
- my $id = shift;
- croak "'$id' is a reserved name. Use something else.\n"
- if $reserved_section_names->{$id} or
- $id =~ /^_/;
-}
-
-sub _make_block {
- my $hunk = shift;
- my $cd = $self->block_delim;
- my $dd = $self->data_delim;
- my $block = $self->block_class->new;
- $hunk =~ s/\A\Q${cd}\E[ \t]*(.*)\s+// or die;
- my $name = $1;
- my @parts = split /^\Q${dd}\E +\(?(\w+)\)? *(.*)?\n/m, $hunk;
- my $description = shift @parts;
- $description ||= '';
- unless ($description =~ /\S/) {
- $description = $name;
- }
- $description =~ s/\s*\z//;
- $block->set_value(description => $description);
-
- my $section_map = {};
- my $section_order = [];
- while (@parts) {
- my ($type, $filters, $value) = splice(@parts, 0, 3);
- $self->_check_reserved($type);
- $value = '' unless defined $value;
- $filters = '' unless defined $filters;
- if ($filters =~ /:(\s|\z)/) {
- croak "Extra lines not allowed in '$type' section"
- if $value =~ /\S/;
- ($filters, $value) = split /\s*:(?:\s+|\z)/, $filters, 2;
- $value = '' unless defined $value;
- $value =~ s/^\s*(.*?)\s*$/$1/;
- }
- $section_map->{$type} = {
- filters => $filters,
- };
- push @$section_order, $type;
- $block->set_value($type, $value);
- }
- $block->set_value(name => $name);
- $block->set_value(_section_map => $section_map);
- $block->set_value(_section_order => $section_order);
- return $block;
-}
-
-sub _spec_init {
- return $self->_spec_string
- if $self->_spec_string;
- local $/;
- my $spec;
- if (my $spec_file = $self->_spec_file) {
- open FILE, $spec_file or die $!;
- $spec = <FILE>;
- close FILE;
- }
- else {
- $spec = do {
- package main;
- no warnings 'once';
- <DATA>;
- };
- }
- return $spec;
-}
-
-sub _strict_warnings() {
- require Filter::Util::Call;
- my $done = 0;
- Filter::Util::Call::filter_add(
- sub {
- return 0 if $done;
- my ($data, $end) = ('', '');
- while (my $status = Filter::Util::Call::filter_read()) {
- return $status if $status < 0;
- if (/^__(?:END|DATA)__\r?$/) {
- $end = $_;
- last;
- }
- $data .= $_;
- $_ = '';
- }
- $_ = "use strict;use warnings;$data$end";
- $done = 1;
- }
- );
-}
-
-sub tie_output() {
- my $handle = shift;
- die "No buffer to tie" unless @_;
- tie $handle, 'Test::Base::Handle', $_[0];
-}
-
-sub no_diff {
- $ENV{TEST_SHOW_NO_DIFFS} = 1;
-}
-
-package Test::Base::Handle;
-
-sub TIEHANDLE() {
- my $class = shift;
- bless \ $_[0], $class;
-}
-
-sub PRINT {
- $$self .= $_ for @_;
-}
-
-#===============================================================================
-# Test::Base::Block
-#
-# This is the default class for accessing a Test::Base block object.
-#===============================================================================
-package Test::Base::Block;
-our @ISA = qw(Spiffy);
-
-our @EXPORT = qw(block_accessor);
-
-sub AUTOLOAD {
- return;
-}
-
-sub block_accessor() {
- my $accessor = shift;
- no strict 'refs';
- return if defined &$accessor;
- *$accessor = sub {
- my $self = shift;
- if (@_) {
- Carp::croak "Not allowed to set values for '$accessor'";
- }
- my @list = @{$self->{$accessor} || []};
- return wantarray
- ? (@list)
- : $list[0];
- };
-}
-
-block_accessor 'name';
-block_accessor 'description';
-Spiffy::field 'seq_num';
-Spiffy::field 'is_filtered';
-Spiffy::field 'blocks_object';
-Spiffy::field 'original_values' => {};
-
-sub set_value {
- no strict 'refs';
- my $accessor = shift;
- block_accessor $accessor
- unless defined &$accessor;
- $self->{$accessor} = [@_];
-}
-
-sub run_filters {
- my $map = $self->_section_map;
- my $order = $self->_section_order;
- Carp::croak "Attempt to filter a block twice"
- if $self->is_filtered;
- for my $type (@$order) {
- my $filters = $map->{$type}{filters};
- my @value = $self->$type;
- $self->original_values->{$type} = $value[0];
- for my $filter ($self->_get_filters($type, $filters)) {
- $Test::Base::Filter::arguments =
- $filter =~ s/=(.*)$// ? $1 : undef;
- my $function = "main::$filter";
- no strict 'refs';
- if (defined &$function) {
- local $_ =
- (@value == 1 and not defined($value[0])) ? undef :
- join '', @value;
- my $old = $_;
- @value = &$function(@value);
- if (not(@value) or
- @value == 1 and defined($value[0]) and $value[0] =~ /\A(\d+|)\z/
- ) {
- if ($value[0] && $_ eq $old) {
- Test::Base::diag("Filters returning numbers are supposed to do munging \$_: your filter '$function' apparently doesn't.");
- }
- @value = ($_);
- }
- }
- else {
- my $filter_object = $self->blocks_object->filter_class->new;
- die "Can't find a function or method for '$filter' filter\n"
- unless $filter_object->can($filter);
- $filter_object->current_block($self);
- @value = $filter_object->$filter(@value);
- }
- # Set the value after each filter since other filters may be
- # introspecting.
- $self->set_value($type, @value);
- }
- }
- $self->is_filtered(1);
-}
-
-sub _get_filters {
- my $type = shift;
- my $string = shift || '';
- $string =~ s/\s*(.*?)\s*/$1/;
- my @filters = ();
- my $map_filters = $self->blocks_object->_filters_map->{$type} || [];
- $map_filters = [ $map_filters ] unless ref $map_filters;
- my @append = ();
- for (
- @{$self->blocks_object->_filters},
- @$map_filters,
- split(/\s+/, $string),
- ) {
- my $filter = $_;
- last unless length $filter;
- if ($filter =~ s/^-//) {
- @filters = grep { $_ ne $filter } @filters;
- }
- elsif ($filter =~ s/^\+//) {
- push @append, $filter;
- }
- else {
- push @filters, $filter;
- }
- }
- return @filters, @append;
-}
-
-{
- %$reserved_section_names = map {
- ($_, 1);
- } keys(%Test::Base::Block::), qw( new DESTROY );
-}
-
-__DATA__
-
-=encoding utf8
-
-#line 1376
@@ -1,73 +0,0 @@
-#line 1
-package Test::Builder::Module;
-
-use strict;
-
-use Test::Builder;
-
-require Exporter;
-our @ISA = qw(Exporter);
-
-our $VERSION = '0.94';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-
-#line 74
-
-sub import {
- my($class) = shift;
-
- # Don't run all this when loading ourself.
- return 1 if $class eq 'Test::Builder::Module';
-
- my $test = $class->builder;
-
- my $caller = caller;
-
- $test->exported_to($caller);
-
- $class->import_extra( \@_ );
- my(@imports) = $class->_strip_imports( \@_ );
-
- $test->plan(@_);
-
- $class->export_to_level( 1, $class, @imports );
-}
-
-sub _strip_imports {
- my $class = shift;
- my $list = shift;
-
- my @imports = ();
- my @other = ();
- my $idx = 0;
- while( $idx <= $#{$list} ) {
- my $item = $list->[$idx];
-
- if( defined $item and $item eq 'import' ) {
- push @imports, @{ $list->[ $idx + 1 ] };
- $idx++;
- }
- else {
- push @other, $item;
- }
-
- $idx++;
- }
-
- @$list = @other;
-
- return @imports;
-}
-
-#line 137
-
-sub import_extra { }
-
-#line 167
-
-sub builder {
- return Test::Builder->new;
-}
-
-1;
@@ -1,1589 +0,0 @@
-#line 1
-package Test::Builder;
-
-use 5.006;
-use strict;
-use warnings;
-
-our $VERSION = '0.94';
-$VERSION = eval $VERSION; ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
-BEGIN {
- if( $] < 5.008 ) {
- require Test::Builder::IO::Scalar;
- }
-}
-
-
-# Make Test::Builder thread-safe for ithreads.
-BEGIN {
- use Config;
- # Load threads::shared when threads are turned on.
- # 5.8.0's threads are so busted we no longer support them.
- if( $] >= 5.008001 && $Config{useithreads} && $INC{'threads.pm'} ) {
- require threads::shared;
-
- # Hack around YET ANOTHER threads::shared bug. It would
- # occassionally forget the contents of the variable when sharing it.
- # So we first copy the data, then share, then put our copy back.
- *share = sub (\[$@%]) {
- my $type = ref $_[0];
- my $data;
-
- if( $type eq 'HASH' ) {
- %$data = %{ $_[0] };
- }
- elsif( $type eq 'ARRAY' ) {
- @$data = @{ $_[0] };
- }
- elsif( $type eq 'SCALAR' ) {
- $$data = ${ $_[0] };
- }
- else {
- die( "Unknown type: " . $type );
- }
-
- $_[0] = &threads::shared::share( $_[0] );
-
- if( $type eq 'HASH' ) {
- %{ $_[0] } = %$data;
- }
- elsif( $type eq 'ARRAY' ) {
- @{ $_[0] } = @$data;
- }
- elsif( $type eq 'SCALAR' ) {
- ${ $_[0] } = $$data;
- }
- else {
- die( "Unknown type: " . $type );
- }
-
- return $_[0];
- };
- }
- # 5.8.0's threads::shared is busted when threads are off
- # and earlier Perls just don't have that module at all.
- else {
- *share = sub { return $_[0] };
- *lock = sub { 0 };
- }
-}
-
-#line 117
-
-our $Test = Test::Builder->new;
-
-sub new {
- my($class) = shift;
- $Test ||= $class->create;
- return $Test;
-}
-
-#line 139
-
-sub create {
- my $class = shift;
-
- my $self = bless {}, $class;
- $self->reset;
-
- return $self;
-}
-
-#line 168
-
-sub child {
- my( $self, $name ) = @_;
-
- if( $self->{Child_Name} ) {
- $self->croak("You already have a child named ($self->{Child_Name}) running");
- }
-
- my $child = bless {}, ref $self;
- $child->reset;
-
- # Add to our indentation
- $child->_indent( $self->_indent . ' ' );
- $child->{$_} = $self->{$_} foreach qw{Out_FH Todo_FH Fail_FH};
-
- # This will be reset in finalize. We do this here lest one child failure
- # cause all children to fail.
- $child->{Child_Error} = $?;
- $? = 0;
- $child->{Parent} = $self;
- $child->{Name} = $name || "Child of " . $self->name;
- $self->{Child_Name} = $child->name;
- return $child;
-}
-
-
-#line 201
-
-sub subtest {
- my $self = shift;
- my($name, $subtests) = @_;
-
- if ('CODE' ne ref $subtests) {
- $self->croak("subtest()'s second argument must be a code ref");
- }
-
- # Turn the child into the parent so anyone who has stored a copy of
- # the Test::Builder singleton will get the child.
- my $child = $self->child($name);
- my %parent = %$self;
- %$self = %$child;
-
- my $error;
- if( !eval { $subtests->(); 1 } ) {
- $error = $@;
- }
-
- # Restore the parent and the copied child.
- %$child = %$self;
- %$self = %parent;
-
- # Die *after* we restore the parent.
- die $error if $error and !eval { $error->isa('Test::Builder::Exception') };
-
- return $child->finalize;
-}
-
-
-#line 250
-
-sub finalize {
- my $self = shift;
-
- return unless $self->parent;
- if( $self->{Child_Name} ) {
- $self->croak("Can't call finalize() with child ($self->{Child_Name}) active");
- }
- $self->_ending;
-
- # XXX This will only be necessary for TAP envelopes (we think)
- #$self->_print( $self->is_passing ? "PASS\n" : "FAIL\n" );
-
- my $ok = 1;
- $self->parent->{Child_Name} = undef;
- if ( $self->{Skip_All} ) {
- $self->parent->skip($self->{Skip_All});
- }
- elsif ( not @{ $self->{Test_Results} } ) {
- $self->parent->ok( 0, sprintf q[No tests run for subtest "%s"], $self->name );
- }
- else {
- $self->parent->ok( $self->is_passing, $self->name );
- }
- $? = $self->{Child_Error};
- delete $self->{Parent};
-
- return $self->is_passing;
-}
-
-sub _indent {
- my $self = shift;
-
- if( @_ ) {
- $self->{Indent} = shift;
- }
-
- return $self->{Indent};
-}
-
-#line 300
-
-sub parent { shift->{Parent} }
-
-#line 312
-
-sub name { shift->{Name} }
-
-sub DESTROY {
- my $self = shift;
- if ( $self->parent ) {
- my $name = $self->name;
- $self->diag(<<"FAIL");
-Child ($name) exited without calling finalize()
-FAIL
- $self->parent->{In_Destroy} = 1;
- $self->parent->ok(0, $name);
- }
-}
-
-#line 336
-
-our $Level;
-
-sub reset { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my($self) = @_;
-
- # We leave this a global because it has to be localized and localizing
- # hash keys is just asking for pain. Also, it was documented.
- $Level = 1;
-
- $self->{Name} = $0;
- $self->is_passing(1);
- $self->{Ending} = 0;
- $self->{Have_Plan} = 0;
- $self->{No_Plan} = 0;
- $self->{Have_Output_Plan} = 0;
-
- $self->{Original_Pid} = $$;
- $self->{Child_Name} = undef;
- $self->{Indent} ||= '';
-
- share( $self->{Curr_Test} );
- $self->{Curr_Test} = 0;
- $self->{Test_Results} = &share( [] );
-
- $self->{Exported_To} = undef;
- $self->{Expected_Tests} = 0;
-
- $self->{Skip_All} = 0;
-
- $self->{Use_Nums} = 1;
-
- $self->{No_Header} = 0;
- $self->{No_Ending} = 0;
-
- $self->{Todo} = undef;
- $self->{Todo_Stack} = [];
- $self->{Start_Todo} = 0;
- $self->{Opened_Testhandles} = 0;
-
- $self->_dup_stdhandles;
-
- return;
-}
-
-#line 414
-
-my %plan_cmds = (
- no_plan => \&no_plan,
- skip_all => \&skip_all,
- tests => \&_plan_tests,
-);
-
-sub plan {
- my( $self, $cmd, $arg ) = @_;
-
- return unless $cmd;
-
- local $Level = $Level + 1;
-
- $self->croak("You tried to plan twice") if $self->{Have_Plan};
-
- if( my $method = $plan_cmds{$cmd} ) {
- local $Level = $Level + 1;
- $self->$method($arg);
- }
- else {
- my @args = grep { defined } ( $cmd, $arg );
- $self->croak("plan() doesn't understand @args");
- }
-
- return 1;
-}
-
-
-sub _plan_tests {
- my($self, $arg) = @_;
-
- if($arg) {
- local $Level = $Level + 1;
- return $self->expected_tests($arg);
- }
- elsif( !defined $arg ) {
- $self->croak("Got an undefined number of tests");
- }
- else {
- $self->croak("You said to run 0 tests");
- }
-
- return;
-}
-
-
-#line 470
-
-sub expected_tests {
- my $self = shift;
- my($max) = @_;
-
- if(@_) {
- $self->croak("Number of tests must be a positive integer. You gave it '$max'")
- unless $max =~ /^\+?\d+$/;
-
- $self->{Expected_Tests} = $max;
- $self->{Have_Plan} = 1;
-
- $self->_output_plan($max) unless $self->no_header;
- }
- return $self->{Expected_Tests};
-}
-
-#line 494
-
-sub no_plan {
- my($self, $arg) = @_;
-
- $self->carp("no_plan takes no arguments") if $arg;
-
- $self->{No_Plan} = 1;
- $self->{Have_Plan} = 1;
-
- return 1;
-}
-
-
-#line 528
-
-sub _output_plan {
- my($self, $max, $directive, $reason) = @_;
-
- $self->carp("The plan was already output") if $self->{Have_Output_Plan};
-
- my $plan = "1..$max";
- $plan .= " # $directive" if defined $directive;
- $plan .= " $reason" if defined $reason;
-
- $self->_print("$plan\n");
-
- $self->{Have_Output_Plan} = 1;
-
- return;
-}
-
-#line 579
-
-sub done_testing {
- my($self, $num_tests) = @_;
-
- # If done_testing() specified the number of tests, shut off no_plan.
- if( defined $num_tests ) {
- $self->{No_Plan} = 0;
- }
- else {
- $num_tests = $self->current_test;
- }
-
- if( $self->{Done_Testing} ) {
- my($file, $line) = @{$self->{Done_Testing}}[1,2];
- $self->ok(0, "done_testing() was already called at $file line $line");
- return;
- }
-
- $self->{Done_Testing} = [caller];
-
- if( $self->expected_tests && $num_tests != $self->expected_tests ) {
- $self->ok(0, "planned to run @{[ $self->expected_tests ]} ".
- "but done_testing() expects $num_tests");
- }
- else {
- $self->{Expected_Tests} = $num_tests;
- }
-
- $self->_output_plan($num_tests) unless $self->{Have_Output_Plan};
-
- $self->{Have_Plan} = 1;
-
- # The wrong number of tests were run
- $self->is_passing(0) if $self->{Expected_Tests} != $self->{Curr_Test};
-
- # No tests were run
- $self->is_passing(0) if $self->{Curr_Test} == 0;
-
- return 1;
-}
-
-
-#line 630
-
-sub has_plan {
- my $self = shift;
-
- return( $self->{Expected_Tests} ) if $self->{Expected_Tests};
- return('no_plan') if $self->{No_Plan};
- return(undef);
-}
-
-#line 647
-
-sub skip_all {
- my( $self, $reason ) = @_;
-
- $self->{Skip_All} = $self->parent ? $reason : 1;
-
- $self->_output_plan(0, "SKIP", $reason) unless $self->no_header;
- if ( $self->parent ) {
- die bless {} => 'Test::Builder::Exception';
- }
- exit(0);
-}
-
-#line 672
-
-sub exported_to {
- my( $self, $pack ) = @_;
-
- if( defined $pack ) {
- $self->{Exported_To} = $pack;
- }
- return $self->{Exported_To};
-}
-
-#line 702
-
-sub ok {
- my( $self, $test, $name ) = @_;
-
- if ( $self->{Child_Name} and not $self->{In_Destroy} ) {
- $name = 'unnamed test' unless defined $name;
- $self->is_passing(0);
- $self->croak("Cannot run test ($name) with active children");
- }
- # $test might contain an object which we don't want to accidentally
- # store, so we turn it into a boolean.
- $test = $test ? 1 : 0;
-
- lock $self->{Curr_Test};
- $self->{Curr_Test}++;
-
- # In case $name is a string overloaded object, force it to stringify.
- $self->_unoverload_str( \$name );
-
- $self->diag(<<"ERR") if defined $name and $name =~ /^[\d\s]+$/;
- You named your test '$name'. You shouldn't use numbers for your test names.
- Very confusing.
-ERR
-
- # Capture the value of $TODO for the rest of this ok() call
- # so it can more easily be found by other routines.
- my $todo = $self->todo();
- my $in_todo = $self->in_todo;
- local $self->{Todo} = $todo if $in_todo;
-
- $self->_unoverload_str( \$todo );
-
- my $out;
- my $result = &share( {} );
-
- unless($test) {
- $out .= "not ";
- @$result{ 'ok', 'actual_ok' } = ( ( $self->in_todo ? 1 : 0 ), 0 );
- }
- else {
- @$result{ 'ok', 'actual_ok' } = ( 1, $test );
- }
-
- $out .= "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
-
- if( defined $name ) {
- $name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
- $out .= " - $name";
- $result->{name} = $name;
- }
- else {
- $result->{name} = '';
- }
-
- if( $self->in_todo ) {
- $out .= " # TODO $todo";
- $result->{reason} = $todo;
- $result->{type} = 'todo';
- }
- else {
- $result->{reason} = '';
- $result->{type} = '';
- }
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = $result;
- $out .= "\n";
-
- $self->_print($out);
-
- unless($test) {
- my $msg = $self->in_todo ? "Failed (TODO)" : "Failed";
- $self->_print_to_fh( $self->_diag_fh, "\n" ) if $ENV{HARNESS_ACTIVE};
-
- my( undef, $file, $line ) = $self->caller;
- if( defined $name ) {
- $self->diag(qq[ $msg test '$name'\n]);
- $self->diag(qq[ at $file line $line.\n]);
- }
- else {
- $self->diag(qq[ $msg test at $file line $line.\n]);
- }
- }
-
- $self->is_passing(0) unless $test || $self->in_todo;
-
- # Check that we haven't violated the plan
- $self->_check_is_passing_plan();
-
- return $test ? 1 : 0;
-}
-
-
-# Check that we haven't yet violated the plan and set
-# is_passing() accordingly
-sub _check_is_passing_plan {
- my $self = shift;
-
- my $plan = $self->has_plan;
- return unless defined $plan; # no plan yet defined
- return unless $plan !~ /\D/; # no numeric plan
- $self->is_passing(0) if $plan < $self->{Curr_Test};
-}
-
-
-sub _unoverload {
- my $self = shift;
- my $type = shift;
-
- $self->_try(sub { require overload; }, die_on_fail => 1);
-
- foreach my $thing (@_) {
- if( $self->_is_object($$thing) ) {
- if( my $string_meth = overload::Method( $$thing, $type ) ) {
- $$thing = $$thing->$string_meth();
- }
- }
- }
-
- return;
-}
-
-sub _is_object {
- my( $self, $thing ) = @_;
-
- return $self->_try( sub { ref $thing && $thing->isa('UNIVERSAL') } ) ? 1 : 0;
-}
-
-sub _unoverload_str {
- my $self = shift;
-
- return $self->_unoverload( q[""], @_ );
-}
-
-sub _unoverload_num {
- my $self = shift;
-
- $self->_unoverload( '0+', @_ );
-
- for my $val (@_) {
- next unless $self->_is_dualvar($$val);
- $$val = $$val + 0;
- }
-
- return;
-}
-
-# This is a hack to detect a dualvar such as $!
-sub _is_dualvar {
- my( $self, $val ) = @_;
-
- # Objects are not dualvars.
- return 0 if ref $val;
-
- no warnings 'numeric';
- my $numval = $val + 0;
- return $numval != 0 and $numval ne $val ? 1 : 0;
-}
-
-#line 876
-
-sub is_eq {
- my( $self, $got, $expect, $name ) = @_;
- local $Level = $Level + 1;
-
- $self->_unoverload_str( \$got, \$expect );
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok( $test, $name );
- $self->_is_diag( $got, 'eq', $expect ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, 'eq', $expect, $name );
-}
-
-sub is_num {
- my( $self, $got, $expect, $name ) = @_;
- local $Level = $Level + 1;
-
- $self->_unoverload_num( \$got, \$expect );
-
- if( !defined $got || !defined $expect ) {
- # undef only matches undef and nothing else
- my $test = !defined $got && !defined $expect;
-
- $self->ok( $test, $name );
- $self->_is_diag( $got, '==', $expect ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, '==', $expect, $name );
-}
-
-sub _diag_fmt {
- my( $self, $type, $val ) = @_;
-
- if( defined $$val ) {
- if( $type eq 'eq' or $type eq 'ne' ) {
- # quote and force string context
- $$val = "'$$val'";
- }
- else {
- # force numeric context
- $self->_unoverload_num($val);
- }
- }
- else {
- $$val = 'undef';
- }
-
- return;
-}
-
-sub _is_diag {
- my( $self, $got, $type, $expect ) = @_;
-
- $self->_diag_fmt( $type, $_ ) for \$got, \$expect;
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- got: $got
- expected: $expect
-DIAGNOSTIC
-
-}
-
-sub _isnt_diag {
- my( $self, $got, $type ) = @_;
-
- $self->_diag_fmt( $type, \$got );
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- got: $got
- expected: anything else
-DIAGNOSTIC
-}
-
-#line 973
-
-sub isnt_eq {
- my( $self, $got, $dont_expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok( $test, $name );
- $self->_isnt_diag( $got, 'ne' ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, 'ne', $dont_expect, $name );
-}
-
-sub isnt_num {
- my( $self, $got, $dont_expect, $name ) = @_;
- local $Level = $Level + 1;
-
- if( !defined $got || !defined $dont_expect ) {
- # undef only matches undef and nothing else
- my $test = defined $got || defined $dont_expect;
-
- $self->ok( $test, $name );
- $self->_isnt_diag( $got, '!=' ) unless $test;
- return $test;
- }
-
- return $self->cmp_ok( $got, '!=', $dont_expect, $name );
-}
-
-#line 1022
-
-sub like {
- my( $self, $this, $regex, $name ) = @_;
-
- local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '=~', $name );
-}
-
-sub unlike {
- my( $self, $this, $regex, $name ) = @_;
-
- local $Level = $Level + 1;
- return $self->_regex_ok( $this, $regex, '!~', $name );
-}
-
-#line 1046
-
-my %numeric_cmps = map { ( $_, 1 ) } ( "<", "<=", ">", ">=", "==", "!=", "<=>" );
-
-sub cmp_ok {
- my( $self, $got, $type, $expect, $name ) = @_;
-
- my $test;
- my $error;
- {
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
-
- my($pack, $file, $line) = $self->caller();
-
- $test = eval qq[
-#line 1 "cmp_ok [from $file line $line]"
-\$got $type \$expect;
-];
- $error = $@;
- }
- local $Level = $Level + 1;
- my $ok = $self->ok( $test, $name );
-
- # Treat overloaded objects as numbers if we're asked to do a
- # numeric comparison.
- my $unoverload
- = $numeric_cmps{$type}
- ? '_unoverload_num'
- : '_unoverload_str';
-
- $self->diag(<<"END") if $error;
-An error occurred while using $type:
-------------------------------------
-$error
-------------------------------------
-END
-
- unless($ok) {
- $self->$unoverload( \$got, \$expect );
-
- if( $type =~ /^(eq|==)$/ ) {
- $self->_is_diag( $got, $type, $expect );
- }
- elsif( $type =~ /^(ne|!=)$/ ) {
- $self->_isnt_diag( $got, $type );
- }
- else {
- $self->_cmp_diag( $got, $type, $expect );
- }
- }
- return $ok;
-}
-
-sub _cmp_diag {
- my( $self, $got, $type, $expect ) = @_;
-
- $got = defined $got ? "'$got'" : 'undef';
- $expect = defined $expect ? "'$expect'" : 'undef';
-
- local $Level = $Level + 1;
- return $self->diag(<<"DIAGNOSTIC");
- $got
- $type
- $expect
-DIAGNOSTIC
-}
-
-sub _caller_context {
- my $self = shift;
-
- my( $pack, $file, $line ) = $self->caller(1);
-
- my $code = '';
- $code .= "#line $line $file\n" if defined $file and defined $line;
-
- return $code;
-}
-
-#line 1145
-
-sub BAIL_OUT {
- my( $self, $reason ) = @_;
-
- $self->{Bailed_Out} = 1;
- $self->_print("Bail out! $reason");
- exit 255;
-}
-
-#line 1158
-
-{
- no warnings 'once';
- *BAILOUT = \&BAIL_OUT;
-}
-
-#line 1172
-
-sub skip {
- my( $self, $why ) = @_;
- $why ||= '';
- $self->_unoverload_str( \$why );
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 1,
- name => '',
- type => 'skip',
- reason => $why,
- }
- );
-
- my $out = "ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # skip";
- $out .= " $why" if length $why;
- $out .= "\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-#line 1213
-
-sub todo_skip {
- my( $self, $why ) = @_;
- $why ||= '';
-
- lock( $self->{Curr_Test} );
- $self->{Curr_Test}++;
-
- $self->{Test_Results}[ $self->{Curr_Test} - 1 ] = &share(
- {
- 'ok' => 1,
- actual_ok => 0,
- name => '',
- type => 'todo_skip',
- reason => $why,
- }
- );
-
- my $out = "not ok";
- $out .= " $self->{Curr_Test}" if $self->use_numbers;
- $out .= " # TODO & SKIP $why\n";
-
- $self->_print($out);
-
- return 1;
-}
-
-#line 1293
-
-sub maybe_regex {
- my( $self, $regex ) = @_;
- my $usable_regex = undef;
-
- return $usable_regex unless defined $regex;
-
- my( $re, $opts );
-
- # Check for qr/foo/
- if( _is_qr($regex) ) {
- $usable_regex = $regex;
- }
- # Check for '/foo/' or 'm,foo,'
- elsif(( $re, $opts ) = $regex =~ m{^ /(.*)/ (\w*) $ }sx or
- ( undef, $re, $opts ) = $regex =~ m,^ m([^\w\s]) (.+) \1 (\w*) $,sx
- )
- {
- $usable_regex = length $opts ? "(?$opts)$re" : $re;
- }
-
- return $usable_regex;
-}
-
-sub _is_qr {
- my $regex = shift;
-
- # is_regexp() checks for regexes in a robust manner, say if they're
- # blessed.
- return re::is_regexp($regex) if defined &re::is_regexp;
- return ref $regex eq 'Regexp';
-}
-
-sub _regex_ok {
- my( $self, $this, $regex, $cmp, $name ) = @_;
-
- my $ok = 0;
- my $usable_regex = $self->maybe_regex($regex);
- unless( defined $usable_regex ) {
- local $Level = $Level + 1;
- $ok = $self->ok( 0, $name );
- $self->diag(" '$regex' doesn't look much like a regex to me.");
- return $ok;
- }
-
- {
- ## no critic (BuiltinFunctions::ProhibitStringyEval)
-
- my $test;
- my $context = $self->_caller_context;
-
- local( $@, $!, $SIG{__DIE__} ); # isolate eval
-
- $test = eval $context . q{$test = $this =~ /$usable_regex/ ? 1 : 0};
-
- $test = !$test if $cmp eq '!~';
-
- local $Level = $Level + 1;
- $ok = $self->ok( $test, $name );
- }
-
- unless($ok) {
- $this = defined $this ? "'$this'" : 'undef';
- my $match = $cmp eq '=~' ? "doesn't match" : "matches";
-
- local $Level = $Level + 1;
- $self->diag( sprintf <<'DIAGNOSTIC', $this, $match, $regex );
- %s
- %13s '%s'
-DIAGNOSTIC
-
- }
-
- return $ok;
-}
-
-# I'm not ready to publish this. It doesn't deal with array return
-# values from the code or context.
-
-#line 1389
-
-sub _try {
- my( $self, $code, %opts ) = @_;
-
- my $error;
- my $return;
- {
- local $!; # eval can mess up $!
- local $@; # don't set $@ in the test
- local $SIG{__DIE__}; # don't trip an outside DIE handler.
- $return = eval { $code->() };
- $error = $@;
- }
-
- die $error if $error and $opts{die_on_fail};
-
- return wantarray ? ( $return, $error ) : $return;
-}
-
-#line 1418
-
-sub is_fh {
- my $self = shift;
- my $maybe_fh = shift;
- return 0 unless defined $maybe_fh;
-
- return 1 if ref $maybe_fh eq 'GLOB'; # its a glob ref
- return 1 if ref \$maybe_fh eq 'GLOB'; # its a glob
-
- return eval { $maybe_fh->isa("IO::Handle") } ||
- eval { tied($maybe_fh)->can('TIEHANDLE') };
-}
-
-#line 1461
-
-sub level {
- my( $self, $level ) = @_;
-
- if( defined $level ) {
- $Level = $level;
- }
- return $Level;
-}
-
-#line 1493
-
-sub use_numbers {
- my( $self, $use_nums ) = @_;
-
- if( defined $use_nums ) {
- $self->{Use_Nums} = $use_nums;
- }
- return $self->{Use_Nums};
-}
-
-#line 1526
-
-foreach my $attribute (qw(No_Header No_Ending No_Diag)) {
- my $method = lc $attribute;
-
- my $code = sub {
- my( $self, $no ) = @_;
-
- if( defined $no ) {
- $self->{$attribute} = $no;
- }
- return $self->{$attribute};
- };
-
- no strict 'refs'; ## no critic
- *{ __PACKAGE__ . '::' . $method } = $code;
-}
-
-#line 1579
-
-sub diag {
- my $self = shift;
-
- $self->_print_comment( $self->_diag_fh, @_ );
-}
-
-#line 1594
-
-sub note {
- my $self = shift;
-
- $self->_print_comment( $self->output, @_ );
-}
-
-sub _diag_fh {
- my $self = shift;
-
- local $Level = $Level + 1;
- return $self->in_todo ? $self->todo_output : $self->failure_output;
-}
-
-sub _print_comment {
- my( $self, $fh, @msgs ) = @_;
-
- return if $self->no_diag;
- return unless @msgs;
-
- # Prevent printing headers when compiling (i.e. -c)
- return if $^C;
-
- # Smash args together like print does.
- # Convert undef to 'undef' so its readable.
- my $msg = join '', map { defined($_) ? $_ : 'undef' } @msgs;
-
- # Escape the beginning, _print will take care of the rest.
- $msg =~ s/^/# /;
-
- local $Level = $Level + 1;
- $self->_print_to_fh( $fh, $msg );
-
- return 0;
-}
-
-#line 1644
-
-sub explain {
- my $self = shift;
-
- return map {
- ref $_
- ? do {
- $self->_try(sub { require Data::Dumper }, die_on_fail => 1);
-
- my $dumper = Data::Dumper->new( [$_] );
- $dumper->Indent(1)->Terse(1);
- $dumper->Sortkeys(1) if $dumper->can("Sortkeys");
- $dumper->Dump;
- }
- : $_
- } @_;
-}
-
-#line 1673
-
-sub _print {
- my $self = shift;
- return $self->_print_to_fh( $self->output, @_ );
-}
-
-sub _print_to_fh {
- my( $self, $fh, @msgs ) = @_;
-
- # Prevent printing headers when only compiling. Mostly for when
- # tests are deparsed with B::Deparse
- return if $^C;
-
- my $msg = join '', @msgs;
-
- local( $\, $", $, ) = ( undef, ' ', '' );
-
- # Escape each line after the first with a # so we don't
- # confuse Test::Harness.
- $msg =~ s{\n(?!\z)}{\n# }sg;
-
- # Stick a newline on the end if it needs it.
- $msg .= "\n" unless $msg =~ /\n\z/;
-
- return print $fh $self->_indent, $msg;
-}
-
-#line 1732
-
-sub output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Out_FH} = $self->_new_fh($fh);
- }
- return $self->{Out_FH};
-}
-
-sub failure_output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Fail_FH} = $self->_new_fh($fh);
- }
- return $self->{Fail_FH};
-}
-
-sub todo_output {
- my( $self, $fh ) = @_;
-
- if( defined $fh ) {
- $self->{Todo_FH} = $self->_new_fh($fh);
- }
- return $self->{Todo_FH};
-}
-
-sub _new_fh {
- my $self = shift;
- my($file_or_fh) = shift;
-
- my $fh;
- if( $self->is_fh($file_or_fh) ) {
- $fh = $file_or_fh;
- }
- elsif( ref $file_or_fh eq 'SCALAR' ) {
- # Scalar refs as filehandles was added in 5.8.
- if( $] >= 5.008 ) {
- open $fh, ">>", $file_or_fh
- or $self->croak("Can't open scalar ref $file_or_fh: $!");
- }
- # Emulate scalar ref filehandles with a tie.
- else {
- $fh = Test::Builder::IO::Scalar->new($file_or_fh)
- or $self->croak("Can't tie scalar ref $file_or_fh");
- }
- }
- else {
- open $fh, ">", $file_or_fh
- or $self->croak("Can't open test output log $file_or_fh: $!");
- _autoflush($fh);
- }
-
- return $fh;
-}
-
-sub _autoflush {
- my($fh) = shift;
- my $old_fh = select $fh;
- $| = 1;
- select $old_fh;
-
- return;
-}
-
-my( $Testout, $Testerr );
-
-sub _dup_stdhandles {
- my $self = shift;
-
- $self->_open_testhandles;
-
- # Set everything to unbuffered else plain prints to STDOUT will
- # come out in the wrong order from our own prints.
- _autoflush($Testout);
- _autoflush( \*STDOUT );
- _autoflush($Testerr);
- _autoflush( \*STDERR );
-
- $self->reset_outputs;
-
- return;
-}
-
-sub _open_testhandles {
- my $self = shift;
-
- return if $self->{Opened_Testhandles};
-
- # We dup STDOUT and STDERR so people can change them in their
- # test suites while still getting normal test output.
- open( $Testout, ">&STDOUT" ) or die "Can't dup STDOUT: $!";
- open( $Testerr, ">&STDERR" ) or die "Can't dup STDERR: $!";
-
- # $self->_copy_io_layers( \*STDOUT, $Testout );
- # $self->_copy_io_layers( \*STDERR, $Testerr );
-
- $self->{Opened_Testhandles} = 1;
-
- return;
-}
-
-sub _copy_io_layers {
- my( $self, $src, $dst ) = @_;
-
- $self->_try(
- sub {
- require PerlIO;
- my @src_layers = PerlIO::get_layers($src);
-
- binmode $dst, join " ", map ":$_", @src_layers if @src_layers;
- }
- );
-
- return;
-}
-
-#line 1857
-
-sub reset_outputs {
- my $self = shift;
-
- $self->output ($Testout);
- $self->failure_output($Testerr);
- $self->todo_output ($Testout);
-
- return;
-}
-
-#line 1883
-
-sub _message_at_caller {
- my $self = shift;
-
- local $Level = $Level + 1;
- my( $pack, $file, $line ) = $self->caller;
- return join( "", @_ ) . " at $file line $line.\n";
-}
-
-sub carp {
- my $self = shift;
- return warn $self->_message_at_caller(@_);
-}
-
-sub croak {
- my $self = shift;
- return die $self->_message_at_caller(@_);
-}
-
-
-#line 1923
-
-sub current_test {
- my( $self, $num ) = @_;
-
- lock( $self->{Curr_Test} );
- if( defined $num ) {
- $self->{Curr_Test} = $num;
-
- # If the test counter is being pushed forward fill in the details.
- my $test_results = $self->{Test_Results};
- if( $num > @$test_results ) {
- my $start = @$test_results ? @$test_results : 0;
- for( $start .. $num - 1 ) {
- $test_results->[$_] = &share(
- {
- 'ok' => 1,
- actual_ok => undef,
- reason => 'incrementing test number',
- type => 'unknown',
- name => undef
- }
- );
- }
- }
- # If backward, wipe history. Its their funeral.
- elsif( $num < @$test_results ) {
- $#{$test_results} = $num - 1;
- }
- }
- return $self->{Curr_Test};
-}
-
-#line 1971
-
-sub is_passing {
- my $self = shift;
-
- if( @_ ) {
- $self->{Is_Passing} = shift;
- }
-
- return $self->{Is_Passing};
-}
-
-
-#line 1993
-
-sub summary {
- my($self) = shift;
-
- return map { $_->{'ok'} } @{ $self->{Test_Results} };
-}
-
-#line 2048
-
-sub details {
- my $self = shift;
- return @{ $self->{Test_Results} };
-}
-
-#line 2077
-
-sub todo {
- my( $self, $pack ) = @_;
-
- return $self->{Todo} if defined $self->{Todo};
-
- local $Level = $Level + 1;
- my $todo = $self->find_TODO($pack);
- return $todo if defined $todo;
-
- return '';
-}
-
-#line 2099
-
-sub find_TODO {
- my( $self, $pack ) = @_;
-
- $pack = $pack || $self->caller(1) || $self->exported_to;
- return unless $pack;
-
- no strict 'refs'; ## no critic
- return ${ $pack . '::TODO' };
-}
-
-#line 2117
-
-sub in_todo {
- my $self = shift;
-
- local $Level = $Level + 1;
- return( defined $self->{Todo} || $self->find_TODO ) ? 1 : 0;
-}
-
-#line 2167
-
-sub todo_start {
- my $self = shift;
- my $message = @_ ? shift : '';
-
- $self->{Start_Todo}++;
- if( $self->in_todo ) {
- push @{ $self->{Todo_Stack} } => $self->todo;
- }
- $self->{Todo} = $message;
-
- return;
-}
-
-#line 2189
-
-sub todo_end {
- my $self = shift;
-
- if( !$self->{Start_Todo} ) {
- $self->croak('todo_end() called without todo_start()');
- }
-
- $self->{Start_Todo}--;
-
- if( $self->{Start_Todo} && @{ $self->{Todo_Stack} } ) {
- $self->{Todo} = pop @{ $self->{Todo_Stack} };
- }
- else {
- delete $self->{Todo};
- }
-
- return;
-}
-
-#line 2222
-
-sub caller { ## no critic (Subroutines::ProhibitBuiltinHomonyms)
- my( $self, $height ) = @_;
- $height ||= 0;
-
- my $level = $self->level + $height + 1;
- my @caller;
- do {
- @caller = CORE::caller( $level );
- $level--;
- } until @caller;
- return wantarray ? @caller : $caller[0];
-}
-
-#line 2239
-
-#line 2253
-
-#'#
-sub _sanity_check {
- my $self = shift;
-
- $self->_whoa( $self->{Curr_Test} < 0, 'Says here you ran a negative number of tests!' );
- $self->_whoa( $self->{Curr_Test} != @{ $self->{Test_Results} },
- 'Somehow you got a different number of results than tests ran!' );
-
- return;
-}
-
-#line 2274
-
-sub _whoa {
- my( $self, $check, $desc ) = @_;
- if($check) {
- local $Level = $Level + 1;
- $self->croak(<<"WHOA");
-WHOA! $desc
-This should never happen! Please contact the author immediately!
-WHOA
- }
-
- return;
-}
-
-#line 2298
-
-sub _my_exit {
- $? = $_[0]; ## no critic (Variables::RequireLocalizedPunctuationVars)
-
- return 1;
-}
-
-#line 2310
-
-sub _ending {
- my $self = shift;
- return if $self->no_ending;
- return if $self->{Ending}++;
-
- my $real_exit_code = $?;
-
- # Don't bother with an ending if this is a forked copy. Only the parent
- # should do the ending.
- if( $self->{Original_Pid} != $$ ) {
- return;
- }
-
- # Ran tests but never declared a plan or hit done_testing
- if( !$self->{Have_Plan} and $self->{Curr_Test} ) {
- $self->is_passing(0);
- $self->diag("Tests were run but no plan was declared and done_testing() was not seen.");
- }
-
- # Exit if plan() was never called. This is so "require Test::Simple"
- # doesn't puke.
- if( !$self->{Have_Plan} ) {
- return;
- }
-
- # Don't do an ending if we bailed out.
- if( $self->{Bailed_Out} ) {
- $self->is_passing(0);
- return;
- }
- # Figure out if we passed or failed and print helpful messages.
- my $test_results = $self->{Test_Results};
- if(@$test_results) {
- # The plan? We have no plan.
- if( $self->{No_Plan} ) {
- $self->_output_plan($self->{Curr_Test}) unless $self->no_header;
- $self->{Expected_Tests} = $self->{Curr_Test};
- }
-
- # Auto-extended arrays and elements which aren't explicitly
- # filled in with a shared reference will puke under 5.8.0
- # ithreads. So we have to fill them in by hand. :(
- my $empty_result = &share( {} );
- for my $idx ( 0 .. $self->{Expected_Tests} - 1 ) {
- $test_results->[$idx] = $empty_result
- unless defined $test_results->[$idx];
- }
-
- my $num_failed = grep !$_->{'ok'}, @{$test_results}[ 0 .. $self->{Curr_Test} - 1 ];
-
- my $num_extra = $self->{Curr_Test} - $self->{Expected_Tests};
-
- if( $num_extra != 0 ) {
- my $s = $self->{Expected_Tests} == 1 ? '' : 's';
- $self->diag(<<"FAIL");
-Looks like you planned $self->{Expected_Tests} test$s but ran $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- }
-
- if($num_failed) {
- my $num_tests = $self->{Curr_Test};
- my $s = $num_failed == 1 ? '' : 's';
-
- my $qualifier = $num_extra == 0 ? '' : ' run';
-
- $self->diag(<<"FAIL");
-Looks like you failed $num_failed test$s of $num_tests$qualifier.
-FAIL
- $self->is_passing(0);
- }
-
- if($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code just after $self->{Curr_Test}.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
-
- my $exit_code;
- if($num_failed) {
- $exit_code = $num_failed <= 254 ? $num_failed : 254;
- }
- elsif( $num_extra != 0 ) {
- $exit_code = 255;
- }
- else {
- $exit_code = 0;
- }
-
- _my_exit($exit_code) && return;
- }
- elsif( $self->{Skip_All} ) {
- _my_exit(0) && return;
- }
- elsif($real_exit_code) {
- $self->diag(<<"FAIL");
-Looks like your test exited with $real_exit_code before it could output anything.
-FAIL
- $self->is_passing(0);
- _my_exit($real_exit_code) && return;
- }
- else {
- $self->diag("No tests run!\n");
- $self->is_passing(0);
- _my_exit(255) && return;
- }
-
- $self->is_passing(0);
- $self->_whoa( 1, "We fell off the end of _ending()" );
-}
-
-END {
- $Test->_ending if defined $Test;
-}
-
-#line 2498
-
-1;
-
@@ -3,13 +3,14 @@ package Test::TCP;
use strict;
use warnings;
use 5.00800;
-our $VERSION = '0.15';
+our $VERSION = '0.16';
use base qw/Exporter/;
use IO::Socket::INET;
use Test::SharedFork;
use Test::More ();
use Config;
use POSIX;
+use Time::HiRes ();
# process does not die when received SIGTERM, on win32.
my $TERMSIG = $^O eq 'MSWin32' ? 'KILL' : 'TERM';
@@ -109,10 +110,10 @@ sub _check_port {
sub wait_port {
my $port = shift;
- my $retry = 10;
+ my $retry = 100;
while ( $retry-- ) {
return if _check_port($port);
- sleep 1;
+ Time::HiRes::sleep(0.1);
}
die "cannot open port: $port";
}
@@ -122,4 +123,4 @@ __END__
=encoding utf8
-#line 240
+#line 241
@@ -26,9 +26,25 @@ sub req_to_psgi {
$uri->host('localhost') unless $uri->host;
$uri->port(80) unless $uri->port;
$uri->host_port($host) unless !$host || ( $host eq $uri->host_port );
- $uri = $uri->canonical;
- open my $input, "<", \do { $req->content };
+ # STUPID: If the request URI is utf-8 decoded, methods like ->path
+ # and ->host returns decoded strings in ascii, which causes double
+ # encoded strings in uri_unescape and URI concatenation in
+ # Plack::Request :/
+ utf8::downgrade $$uri;
+
+ my $input;
+ my $content = $req->content;
+ if (ref $content eq 'CODE') {
+ if (defined $req->content_length) {
+ $input = HTTP::Message::PSGI::ChunkedInput->new($content);
+ } else {
+ $req->header("Transfer-Encoding" => "chunked");
+ $input = HTTP::Message::PSGI::ChunkedInput->new($content, 1);
+ }
+ } else {
+ open $input, "<", \$content;
+ }
my $env = {
PATH_INFO => URI::Escape::uri_unescape($uri->path),
@@ -42,7 +58,7 @@ sub req_to_psgi {
REMOTE_PORT => int( rand(64000) + 1000 ), # not in RFC 3875
REQUEST_URI => $uri->path_query, # not in RFC 3875
REQUEST_METHOD => $req->method,
- 'psgi.version' => [ 1, 0 ],
+ 'psgi.version' => [ 1, 1 ],
'psgi.url_scheme' => $uri->scheme eq 'https' ? 'https' : 'http',
'psgi.input' => $input,
'psgi.errors' => *STDERR,
@@ -50,6 +66,7 @@ sub req_to_psgi {
'psgi.multiprocess' => $FALSE,
'psgi.run_once' => $TRUE,
'psgi.streaming' => $TRUE,
+ 'psgi.nonblocking' => $FALSE,
@_,
};
@@ -132,6 +149,48 @@ sub HTTP::Response::from_psgi {
res_from_psgi(@_);
}
+package
+ HTTP::Message::PSGI::ChunkedInput;
+
+sub new {
+ my($class, $content, $chunked) = @_;
+
+ my $content_cb;
+ if ($chunked) {
+ my $done;
+ $content_cb = sub {
+ my $chunk = $content->();
+ return if $done;
+ unless (defined $chunk) {
+ $done = 1;
+ return "0\015\012\015\012";
+ }
+ return '' unless length $chunk;
+ return sprintf('%x', length $chunk) . "\015\012$chunk\015\012";
+ };
+ } else {
+ $content_cb = $content;
+ }
+
+ bless { content => $content_cb }, $class;
+}
+
+sub read {
+ my $self = shift;
+
+ my $chunk = $self->{content}->();
+ return 0 unless defined $chunk;
+
+ $_[0] = '';
+ substr($_[0], $_[2] || 0, length $chunk) = $chunk;
+
+ return length $chunk;
+}
+
+sub close { }
+
+package HTTP::Message::PSGI;
+
1;
__END__
@@ -0,0 +1,371 @@
+package HTTP::Server::PSGI;
+use strict;
+use warnings;
+
+use Plack;
+use Plack::HTTPParser qw( parse_http_request );
+use IO::Socket::INET;
+use HTTP::Date;
+use HTTP::Status;
+use List::Util qw(max sum);
+use Plack::Util;
+use Plack::TempBuffer;
+use Plack::Middleware::ContentLength;
+use POSIX qw(EINTR);
+use Socket qw(IPPROTO_TCP TCP_NODELAY);
+
+use Try::Tiny;
+use Time::HiRes qw(time);
+
+my $alarm_interval;
+BEGIN {
+ if ($^O eq 'MSWin32') {
+ $alarm_interval = 1;
+ } else {
+ Time::HiRes->import('alarm');
+ $alarm_interval = 0.1;
+ }
+}
+
+use constant MAX_REQUEST_SIZE => 131072;
+use constant MSWin32 => $^O eq 'MSWin32';
+
+sub new {
+ my($class, %args) = @_;
+
+ my $self = bless {
+ host => $args{host} || 0,
+ port => $args{port} || 8080,
+ timeout => $args{timeout} || 300,
+ keepalive_timeout => $args{keepalive_timeout} || 2,
+ max_keepalive_reqs => $args{max_keepalive_reqs},
+ server_software => $args{server_software} || $class,
+ server_ready => $args{server_ready} || sub {},
+ max_workers => $args{max_workers} || 1,
+ max_reqs_per_child => $args{max_reqs_per_child} || 100,
+ }, $class;
+
+ if ($self->{max_workers} > 1) {
+ try {
+ require Parallel::Prefork;
+ $self->{prefork} = 1;
+ $self->{max_keepalive_reqs} ||= 100;
+ $self->{server_software} .= " (prefork)";
+ } catch {
+ die "You need to install Parallel::Prefork to run multi workers (max_workers=$self->{max_workers}): $_";
+ };
+ }
+
+ unless ($self->{prefork}) {
+ $self->{max_keepalive_reqs} ||= 1;
+ }
+
+ $self;
+}
+
+sub run {
+ my($self, $app) = @_;
+ $self->setup_listener();
+
+ if ($self->{prefork}) {
+ $self->run_prefork($app);
+ } else {
+ $self->accept_loop($app);
+ }
+}
+
+sub setup_listener {
+ my $self = shift;
+ $self->{listen_sock} ||= IO::Socket::INET->new(
+ Listen => SOMAXCONN,
+ LocalPort => $self->{port},
+ LocalAddr => $self->{host},
+ Proto => 'tcp',
+ ReuseAddr => 1,
+ ) or die "failed to listen to port $self->{port}:$!";
+
+ $self->{server_ready}->($self);
+}
+
+sub run_prefork {
+ my($self, $app) = @_;
+
+ my $pm = Parallel::Prefork->new({
+ max_workers => $self->{max_workers},
+ trap_signals => {
+ TERM => 'TERM',
+ HUP => 'TERM',
+ },
+ });
+ while ($pm->signal_received ne 'TERM') {
+ $pm->start and next;
+ $self->accept_loop($app, $self->{max_reqs_per_child});
+ $pm->finish;
+ }
+ $pm->wait_all_children;
+}
+
+sub accept_loop {
+ # TODO handle $max_reqs_per_child
+ my($self, $app, $max_reqs_per_child) = @_;
+ my $proc_req_count = 0;
+
+ $app = Plack::Middleware::ContentLength->wrap($app);
+
+ while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) {
+ local $SIG{PIPE} = 'IGNORE';
+ if (my $conn = $self->{listen_sock}->accept) {
+ $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
+ or die "setsockopt(TCP_NODELAY) failed:$!";
+ my $req_count = 0;
+ while (1) {
+ ++$req_count;
+ ++$proc_req_count;
+ my $env = {
+ SERVER_PORT => $self->{port},
+ SERVER_NAME => $self->{host},
+ SCRIPT_NAME => '',
+ REMOTE_ADDR => $conn->peerhost,
+ 'psgi.version' => [ 1, 1 ],
+ 'psgi.errors' => *STDERR,
+ 'psgi.url_scheme' => 'http',
+ 'psgi.run_once' => Plack::Util::FALSE,
+ 'psgi.multithread' => Plack::Util::FALSE,
+ 'psgi.multiprocess' => $self->{prefork},
+ 'psgi.streaming' => Plack::Util::TRUE,
+ 'psgi.nonblocking' => Plack::Util::FALSE,
+ 'psgix.input.buffered' => Plack::Util::TRUE,
+ };
+
+ # no need to take care of pipelining since this module is a HTTP/1.0 server
+ my $may_keepalive = $req_count < $self->{max_keepalive_reqs};
+ if ($may_keepalive && $max_reqs_per_child && $proc_req_count >= $max_reqs_per_child) {
+ $may_keepalive = undef;
+ }
+ $self->handle_connection($env, $conn, $app, $may_keepalive, $req_count != 1)
+ or last;
+ # TODO add special cases for clients with broken keep-alive support, as well as disabling keep-alive for HTTP/1.0 proxies
+ }
+ }
+ }
+}
+
+sub handle_connection {
+ my($self, $env, $conn, $app, $use_keepalive, $is_keepalive) = @_;
+
+ my $buf = '';
+ my $res = [ 400, [ 'Content-Type' => 'text/plain' ], [ 'Bad Request' ] ];
+
+ while (1) {
+ my $rlen = $self->read_timeout(
+ $conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf),
+ $is_keepalive ? $self->{keepalive_timeout} : $self->{timeout},
+ ) or return;
+ my $reqlen = parse_http_request($buf, $env);
+ if ($reqlen >= 0) {
+ # handle request
+ if ($use_keepalive) {
+ if (my $c = $env->{HTTP_CONNECTION}) {
+ $use_keepalive = undef
+ unless $c =~ /^\s*keep-alive\s*/i;
+ } else {
+ $use_keepalive = undef;
+ }
+ }
+ $buf = substr $buf, $reqlen;
+ if (my $cl = $env->{CONTENT_LENGTH}) {
+ my $buffer = Plack::TempBuffer->new($cl);
+ while ($cl > 0) {
+ my $chunk;
+ if (length $buf) {
+ $chunk = $buf;
+ $buf = '';
+ } else {
+ $self->read_timeout($conn, \$chunk, $cl, 0, $self->{timeout});
+ }
+ $buffer->print($chunk);
+ $cl -= length $chunk;
+ }
+ $env->{'psgi.input'} = $buffer->rewind;
+ } else {
+ open my $input, "<", \$buf;
+ $env->{'psgi.input'} = $input;
+ }
+
+ $res = Plack::Util::run_app $app, $env;
+ last;
+ }
+ if ($reqlen == -2) {
+ # request is incomplete, do nothing
+ } elsif ($reqlen == -1) {
+ # error, close conn
+ last;
+ }
+ }
+
+ if (ref $res eq 'ARRAY') {
+ $self->_handle_response($res, $conn, \$use_keepalive);
+ } elsif (ref $res eq 'CODE') {
+ $res->(sub {
+ $self->_handle_response($_[0], $conn, \$use_keepalive);
+ });
+ } else {
+ die "Bad response $res";
+ }
+
+ return $use_keepalive;
+}
+
+sub _handle_response {
+ my($self, $res, $conn, $use_keepalive_r) = @_;
+
+ my @lines = (
+ "Date: @{[HTTP::Date::time2str()]}\015\012",
+ "Server: $self->{server_software}\015\012",
+ );
+
+ Plack::Util::header_iter($res->[1], sub {
+ my ($k, $v) = @_;
+ if (lc $k eq 'connection') {
+ $$use_keepalive_r = undef
+ if $$use_keepalive_r && lc $v ne 'keep-alive';
+ } else {
+ push @lines, "$k: $v\015\012";
+ }
+ });
+ if ($$use_keepalive_r) {
+ $$use_keepalive_r = undef
+ unless Plack::Util::header_exists($res->[1], 'Content-Length');
+ }
+ push @lines, "Connection: keep-alive\015\012"
+ if $$use_keepalive_r;
+ unshift @lines, "HTTP/1.0 $res->[0] @{[ HTTP::Status::status_message($res->[0]) ]}\015\012";
+ push @lines, "\015\012";
+
+ $self->write_all($conn, join('', @lines), $self->{timeout})
+ or return;
+
+ if (defined $res->[2]) {
+ my $err;
+ my $done;
+ {
+ local $@;
+ eval {
+ Plack::Util::foreach(
+ $res->[2],
+ sub {
+ $self->write_all($conn, $_[0], $self->{timeout})
+ or die "failed to send all data\n";
+ },
+ );
+ $done = 1;
+ };
+ $err = $@;
+ };
+ unless ($done) {
+ if ($err =~ /^failed to send all data\n/) {
+ return;
+ } else {
+ die $err;
+ }
+ }
+ } else {
+ return Plack::Util::inline_object
+ write => sub { $self->write_all($conn, $_[0], $self->{timeout}) },
+ close => sub { };
+ }
+}
+
+# returns 1 if socket is ready, undef on timeout
+sub do_timeout {
+ my ($self, $cb, $timeout) = @_;
+ local $SIG{ALRM} = sub {};
+ my $wait_until = time + $timeout;
+ alarm($timeout);
+ my $ret;
+ while (1) {
+ if ($ret = $cb->()) {
+ last;
+ } elsif (! (! defined($ret) && $! == EINTR)) {
+ undef $ret;
+ last;
+ }
+ # got EINTR
+ my $left = $wait_until - time;
+ last if $left <= 0;
+ alarm($left + $alarm_interval);
+ }
+ alarm(0);
+ $ret;
+}
+
+# returns (positive) number of bytes read, or undef if the socket is to be closed
+sub read_timeout {
+ my ($self, $sock, $buf, $len, $off, $timeout) = @_;
+ $self->do_timeout(sub { $sock->sysread($$buf, $len, $off) }, $timeout);
+}
+
+# returns (positive) number of bytes written, or undef if the socket is to be closed
+sub write_timeout {
+ my ($self, $sock, $buf, $len, $off, $timeout) = @_;
+ $self->do_timeout(sub { $sock->syswrite($buf, $len, $off) }, $timeout);
+}
+
+# writes all data in buf and returns number of bytes written or undef if failed
+sub write_all {
+ my ($self, $sock, $buf, $timeout) = @_;
+ my $off = 0;
+ while (my $len = length($buf) - $off) {
+ my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout)
+ or return;
+ $off += $ret;
+ }
+ return length $buf;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+HTTP::Server::PSGI - Standalone PSGI compatible HTTP server
+
+=head1 SYNOPSIS
+
+ use HTTP::Server::PSGI;
+
+ my $server = HTTP::Server::PSGI->new(
+ host => "127.0.0.1",
+ port => 9091,
+ timeout => 120,
+ );
+
+ $server->run($app);
+
+=head1 DESCRIPTION
+
+HTTP::Server::PSGI is a standalone, single-process and PSGI compatible
+HTTP server implementations. It runs reasonably fast and HTTP/1.0 and
+Keep-Alive requests are supported.
+
+This server should be great for the development and testig, but might
+not be suitable for production.
+
+Some features in HTTP/1.1, notably chunked requests, responses and
+pipeline requests are B<NOT> supported yet.
+
+See L<Starman> if you want a multi-process prefork server with some
+HTTP/1.1 features support.
+
+=head1 AUTHOR
+
+Kazuho Oku
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack::Handler::Standalone>
+
+=cut
@@ -2,17 +2,14 @@ package Plack::App::CGIBin;
use strict;
use warnings;
use parent qw/Plack::App::File/;
-use CGI::Emulate::PSGI;
-use CGI::Compile;
+use Plack::App::WrapCGI;
+
+sub allow_path_info { 1 }
sub serve_path {
my($self, $env, $file) = @_;
- my $app = $self->{_compiled}->{$file} ||= do {
- my $sub = CGI::Compile->compile($file);
- my $app = CGI::Emulate::PSGI->handler($sub);
- };
-
+ my $app = $self->{_compiled}->{$file} ||= Plack::App::WrapCGI->new(script => $file);
$app->($env);
}
@@ -51,12 +48,16 @@ This module does not (yet) stat files nor recompile files on every
request for the interest of performance. You need to restart the
server process to reflect the changes to the CGI scripts.
+See also L<Plack::App::WrapCGI> if you compile one CGI script into a
+PSGI application without serving CGI scripts from a directory, to
+remove overhead of filesystem lookups, etc.
+
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
-L<Plack::App::File> L<CGI::Emulate::PSGI> L<CGI::Compile>
+L<Plack::App::File> L<CGI::Emulate::PSGI> L<CGI::Compile> L<Plack::App::WrapCGI>
=cut
@@ -2,6 +2,7 @@ package Plack::App::Cascade;
use strict;
use base qw(Plack::Component);
+use Plack::Util;
use Plack::Util::Accessor qw(apps catch codes);
sub add {
@@ -19,14 +20,35 @@ sub prepare_app {
sub call {
my($self, $env) = @_;
- my $res = [ 404, [ 'Content-Type' => 'text/html' ], [ '404 Not Found' ] ];
-
- for my $app (@{$self->apps || []}) {
- $res = $app->($env);
- last unless ref $res eq 'ARRAY' && $self->codes->{$res->[0]};
- }
-
- return $res;
+ return sub {
+ my $respond = shift;
+
+ my $res = [ 404, [ 'Content-Type' => 'text/html' ], [ '404 Not Found' ] ];
+
+ my $done;
+ my $respond_wrapper = sub {
+ my $res = shift;
+ if ($self->codes->{$res->[0]}) {
+ return Plack::Util::inline_object
+ write => sub { }, close => sub { };
+ } else {
+ $done = 1;
+ return $respond->($res);
+ }
+ };
+
+ for my $app (@{$self->apps || []}) {
+ $res = $app->($env);
+ if (ref $res eq 'CODE') {
+ $res->($respond_wrapper);
+ } else {
+ $respond_wrapper->($res);
+ }
+ return if $done;
+ }
+
+ $respond->($res);
+ };
}
1;
@@ -58,9 +80,6 @@ Plack::App::Cascade is a Plack middleware component that compounds
several apps and tries them to return the first response that is not
404.
-Note that this application doesn't support I<psgi.streaming>
-interface.
-
=head1 METHODS
=over 4
@@ -3,9 +3,9 @@ use parent qw(Plack::App::File);
use strict;
use warnings;
use Plack::Util;
-use Path::Class;
use HTTP::Date;
use Plack::MIME;
+use DirHandle;
# Stolen from rack/directory.rb
my $dir_file = "<tr><td class='name'><a href='%s'>%s</a></td><td class='size'>%s</td><td class='type'>%s</td><td class='mtime'>%s</td></tr>";
@@ -42,31 +42,34 @@ sub should_handle {
}
sub serve_path {
- my($self, $env, $file, $fullpath) = @_;
+ my($self, $env, $dir, $fullpath) = @_;
- if (-f $file) {
- return $self->SUPER::serve_path($env, $file, $fullpath);
+ if (-f $dir) {
+ return $self->SUPER::serve_path($env, $dir, $fullpath);
}
- my $dir = dir($file);
-
my @files = ([ "../", "Parent Directory", '', '', '' ]);
- my @children = map { [ ($_->is_dir ? ($_->dir_list)[-1] : $_->basename), $_ ] } $dir->children;
+ my $dh = DirHandle->new($dir);
+ my @children;
+ while (defined(my $ent = $dh->read)) {
+ push @children, $ent;
+ }
- for my $child (sort { $a->[0] cmp $b->[0] } @children) {
- my($basename, $file) = @$child;
+ for my $basename (sort { $a cmp $b } @children) {
+ my $file = "$dir/$basename";
my $url = $env->{SCRIPT_NAME} . $env->{PATH_INFO} . $basename;
- if ($file->is_dir) {
+ my $is_dir = -d $file;
+ my @stat = stat _;
+
+ if ($is_dir) {
$basename .= "/";
$url .= "/";
}
- my $mime_type = $file->is_dir ? 'directory' : ( Plack::MIME->mime_type($file) || 'text/plain' );
- my $stat = $file->stat;
-
- push @files, [ $url, $basename, $stat->size, $mime_type, HTTP::Date::time2str($stat->mtime) ];
+ my $mime_type = $is_dir ? 'directory' : ( Plack::MIME->mime_type($file) || 'text/plain' );
+ push @files, [ $url, $basename, $stat[7], $mime_type, HTTP::Date::time2str($stat[9]) ];
}
my $path = Plack::Util::encode_html("Index of $env->{PATH_INFO}");
@@ -31,7 +31,14 @@ sub call {
my $conn = FCGI::Client::Connection->new(sock => $sock);
my $input = delete $env->{'psgi.input'};
- my $content_in = do { local $/; <$input> };
+
+ my $content_in = '';
+ if (my $cl = $env->{CONTENT_LENGTH}) {
+ while ($cl > 0) {
+ my $read = $input->read($content_in, $cl, length $content_in);
+ $cl -= $read;
+ }
+ }
for my $key (keys %$env) {
delete $env->{$key} if $key =~ /^psgi\./;
@@ -3,12 +3,12 @@ use strict;
use warnings;
use parent qw/Plack::Component/;
use File::Spec::Unix;
-use Path::Class 'dir';
+use Cwd ();
use Plack::Util;
use Plack::MIME;
use HTTP::Date;
-use Plack::Util::Accessor qw( root encoding );
+use Plack::Util::Accessor qw( root file encoding );
sub should_handle {
my($self, $file) = @_;
@@ -19,32 +19,62 @@ sub call {
my $self = shift;
my $env = shift;
- my $path = $env->{PATH_INFO};
+ my($file, $path_info) = $self->file || $self->locate_file($env);
+ return $file if ref $file eq 'ARRAY';
+
+ if ($path_info) {
+ $env->{PATH_INFO} =~ s/\Q$path_info\E$//;
+ $env->{SCRIPT_NAME} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
+ $env->{PATH_INFO } = $path_info;
+ } else {
+ $env->{SCRIPT_NAME} = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
+ $env->{PATH_INFO } = '';
+ }
+
+ return $self->serve_path($env, $file);
+}
+
+sub locate_file {
+ my($self, $env) = @_;
+
+ my $path = $env->{PATH_INFO} || '';
if ($path =~ m!\.\.[/\\]!) {
return $self->return_403;
}
- my $docroot = dir($self->root || ".");
- my $file = $docroot->file(File::Spec::Unix->splitpath($path))->absolute;
+ my $docroot = $self->root || ".";
+ my @path = split '/', $path;
+ if (@path) {
+ shift @path if $path[0] eq '';
+ } else {
+ @path = ('.');
+ }
- # Is the requested path within the root?
- if (!$docroot->subsumes($file)) {
- return $self->return_403;
+ my($file, @path_info);
+ while (@path) {
+ my $try = File::Spec::Unix->catfile($docroot, @path);
+ if ($self->should_handle($try)) {
+ $file = $try;
+ last;
+ } elsif (!$self->allow_path_info) {
+ last;
+ }
+ unshift @path_info, pop @path;
}
- # Does the file actually exist?
- if (!$self->should_handle($file)) {
+ if (!$file) {
return $self->return_404;
}
- # If the requested file present but lacking the permission to read it?
if (!-r $file) {
return $self->return_403;
}
- return $self->serve_path($env, $file);
+ return $file, join("/", "", @path_info);
}
+sub allow_path_info { 0 }
+
sub serve_path {
my($self, $env, $file) = @_;
@@ -54,21 +84,19 @@ sub serve_path {
$content_type .= "; charset=" . ($self->encoding || "utf-8");
}
- my $fh = $file->openr
+ open my $fh, "<:raw", $file
or return $self->return_403;
- my $path = $file->stringify;
- $path =~ s!\\!/!g;
- Plack::Util::set_io_path($fh, $path);
- binmode $fh;
+ my @stat = stat $file;
+
+ Plack::Util::set_io_path($fh, Cwd::realpath($file));
- my $stat = $file->stat;
return [
200,
[
'Content-Type' => $content_type,
- 'Content-Length' => $stat->size,
- 'Last-Modified' => HTTP::Date::time2str( $stat->mtime )
+ 'Content-Length' => $stat[7],
+ 'Last-Modified' => HTTP::Date::time2str( $stat[9] )
],
$fh,
];
@@ -95,7 +123,13 @@ Plack::App::File - Serve static files from root directory
=head1 SYNOPSIS
use Plack::App::File;
- my $app = Plack::App::File->new({ root => "/path/to/htdocs" })->to_app;
+ my $app = Plack::App::File->new(root => "/path/to/htdocs")->to_app;
+
+ # Or map the path to a specific file
+ use Plack::Builder;
+ builder {
+ mount "/favicon.ico" => Plack::App::File->new(file => '/path/to/favicon.ico');
+ };
=head1 DESCRIPTION
@@ -113,6 +147,14 @@ as well.
Document root directory. Defaults to C<.> (current directory)
+=item file
+
+The file path to create responses from. Optional.
+
+If it's set the application would B<ALWAYS> create a response out of
+the file and there will be no security check etc. (hence fast). If
+it's not set, the application uses C<root> to find the matching file.
+
=item encoding
Set the file encoding for text files. Defaults to C<utf-8>.
@@ -4,6 +4,8 @@ use warnings;
use parent qw/Plack::App::File/;
use Plack::Util;
+sub allow_path_info { 1 }
+
sub serve_path {
my($self, $env, $file) = @_;
@@ -53,9 +53,15 @@ sub call {
next unless $location eq '' or $path =~ s!\Q$location\E!!;
next unless $path eq '' or $path =~ m!/!;
- local $env->{PATH_INFO} = $path;
- local $env->{SCRIPT_NAME} = $script_name . $location;
- return $app->($env);
+ my $orig_path_info = $env->{PATH_INFO};
+ my $orig_script_name = $env->{SCRIPT_NAME};
+
+ $env->{PATH_INFO} = $path;
+ $env->{SCRIPT_NAME} = $script_name . $location;
+ return $self->response_cb($app->($env), sub {
+ $env->{PATH_INFO} = $orig_path_info;
+ $env->{SCRIPT_NAME} = $orig_script_name;
+ });
}
return [404, [ 'Content-Type' => 'text/plain' ], [ "Not Found" ]];
@@ -0,0 +1,57 @@
+package Plack::App::WrapCGI;
+use strict;
+use warnings;
+use parent qw(Plack::Component);
+use Plack::Util::Accessor qw(script _app);
+use CGI::Emulate::PSGI;
+use CGI::Compile;
+use Carp;
+
+sub prepare_app {
+ my $self = shift;
+ my $script = $self->script
+ or croak "'script' is not set";
+
+ my $sub = CGI::Compile->compile($script);
+ my $app = CGI::Emulate::PSGI->handler($sub);
+
+ $self->_app($app);
+}
+
+sub call {
+ my($self, $env) = @_;
+ $self->_app->($env);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::App::WrapCGI - Compiles a CGI script as PSGI application
+
+=head1 SYNOPSIS
+
+ use Plack::App::WrapCGI;
+
+ my $app = Plack::App::WrapCGI->new(script => "/path/to/script.pl")->to_app;
+
+=head1 DESCRIPTION
+
+Plack::App::WrapCGI compiles a CGI script into a PSGI application
+using L<CGI::Compile> and L<CGI::Emulate::PSGI>, and runs it with any
+PSGI server as a PSGI application.
+
+See also L<Plack::App::CGIBin> if you have a directory that contains a
+lot of CGI scripts and serve them like Apache's mod_cgi.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack::App::CGIBin>
+
+=cut
@@ -39,6 +39,62 @@ sub to_app {
return sub { $self->call(@_) };
}
+
+sub response_cb {
+ my($self, $res, $cb) = @_;
+
+ my $body_filter = sub {
+ my($cb, $res) = @_;
+ my $filter_cb = $cb->($res);
+ # If response_cb returns a callback, treat it as a $body filter
+ if (defined $filter_cb && ref $filter_cb eq 'CODE') {
+ Plack::Util::header_remove($res->[1], 'Content-Length');
+ if (defined $res->[2]) {
+ if (ref $res->[2] eq 'ARRAY') {
+ for my $line (@{$res->[2]}) {
+ $line = $filter_cb->($line);
+ }
+ # Send EOF.
+ push @{ $res->[2] }, $filter_cb->( undef );
+ } else {
+ my $body = $res->[2];
+ my $getline = sub { $body->getline };
+ $res->[2] = Plack::Util::inline_object
+ getline => sub { $filter_cb->($getline->()) },
+ close => sub { $body->close };
+ }
+ } else {
+ return $filter_cb;
+ }
+ }
+ };
+
+ if (ref $res eq 'ARRAY') {
+ $body_filter->($cb, $res);
+ return $res;
+ } elsif (ref $res eq 'CODE') {
+ return sub {
+ my $respond = shift;
+ $res->(sub {
+ my $res = shift;
+ my $filter_cb = $body_filter->($cb, $res);
+ if ($filter_cb) {
+ my $writer = $respond->($res);
+ if ($writer) {
+ return Plack::Util::inline_object
+ write => sub { $writer->write($filter_cb->(@_)) },
+ close => sub { $writer->write($filter_cb->(undef)); $writer->close };
+ }
+ } else {
+ return $respond->($res);
+ }
+ });
+ };
+ }
+
+ return $res;
+}
+
1;
__END__
@@ -0,0 +1,144 @@
+package Plack::Handler::Apache1;
+use strict;
+use Apache::Request;
+use Apache::Constants qw(:common :response);
+
+use Plack::Util;
+use Scalar::Util;
+
+my %apps; # psgi file to $app mapping
+
+sub preload {
+ my $class = shift;
+ for my $app (@_) {
+ $class->load_app($app);
+ }
+}
+
+sub load_app {
+ my($class, $app) = @_;
+ return $apps{$app} ||= do {
+ local $ENV{MOD_PERL}; # trick Catalyst/CGI.pm etc.
+ Plack::Util::load_psgi $app;
+ };
+}
+
+sub handler {
+ my $r = shift;
+ my $apr = Apache::Request->new($r);
+
+ my $psgi = $r->dir_config('psgi_app');
+ my $app = __PACKAGE__->load_app($psgi);
+
+ $r->subprocess_env; # let Apache create %ENV for us :)
+
+ my $env = {
+ %ENV,
+ 'psgi.version' => [ 1, 1 ],
+ 'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
+ 'psgi.input' => $r,
+ 'psgi.errors' => *STDERR,
+ 'psgi.multithread' => Plack::Util::FALSE,
+ 'psgi.multiprocess' => Plack::Util::TRUE,
+ 'psgi.run_once' => Plack::Util::FALSE,
+ 'psgi.streaming' => Plack::Util::TRUE,
+ 'psgi.nonblocking' => Plack::Util::FALSE,
+ };
+
+ my $vpath = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
+
+ my $location = $r->location || "/";
+ $location =~ s{/$}{};
+ (my $path_info = $vpath) =~ s/^\Q$location\E//;
+
+ $env->{SCRIPT_NAME} = $location;
+ $env->{PATH_INFO} = $path_info;
+
+ my $res = $app->($env);
+
+ if (ref $res eq 'ARRAY') {
+ _handle_response($r, $res);
+ }
+ elsif (ref $res eq 'CODE') {
+ $res->(sub {
+ _handle_response($r, $_[0]);
+ });
+ }
+ else {
+ die "Bad response $res";
+ }
+
+ return OK;
+}
+
+sub _handle_response {
+ my ($r, $res) = @_;
+ my ($status, $headers, $body) = @{ $res };
+
+ my $hdrs = ($status >= 200 && $status < 300)
+ ? $r->headers_out : $r->err_headers_out;
+
+ Plack::Util::header_iter($headers, sub {
+ my($h, $v) = @_;
+ if (lc $h eq 'content-type') {
+ $r->content_type($v);
+ } else {
+ $hdrs->add($h => $v);
+ }
+ });
+
+ $r->status($status);
+ $r->send_http_header;
+
+ if (defined $body) {
+ if (Plack::Util::is_real_fh($body)) {
+ $r->send_fd($body);
+ } else {
+ Plack::Util::foreach($body, sub { $r->print(@_) });
+ }
+ }
+ else {
+ return Plack::Util::inline_object
+ write => sub { $r->print(@_) },
+ close => sub { };
+ }
+}
+
+1;
+
+__END__
+
+
+=head1 NAME
+
+Plack::Handler::Apache1 - Apache 1.3.x handlers to run PSGI application
+
+=head1 SYNOPSIS
+
+ <Location />
+ SetHandler perl-script
+ PerlHandler Plack::Handler::Apache1
+ PerlSetVar psgi_app /path/to/app.psgi
+ </Location>
+
+ <Perl>
+ use Plack::Handler::Apache1;
+ Plack::Handler::Apache1->preload("/path/to/app.psgi");
+ </Perl>
+
+=head1 DESCRIPTION
+
+This is a handler module to run any PSGI application with mod_perl on Apache 1.3.x.
+
+=head1 AUTHOR
+
+Aaron Trevena
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack>
+
+=cut
+
@@ -0,0 +1,146 @@
+package Plack::Handler::Apache2;
+use strict;
+use warnings;
+use Apache2::RequestRec;
+use Apache2::RequestIO;
+use Apache2::RequestUtil;
+use Apache2::Response;
+use Apache2::Const -compile => qw(OK);
+use APR::Table;
+use IO::Handle;
+use Plack::Util;
+use Scalar::Util;
+
+my %apps; # psgi file to $app mapping
+
+sub preload {
+ my $class = shift;
+ for my $app (@_) {
+ $class->load_app($app);
+ }
+}
+
+sub load_app {
+ my($class, $app) = @_;
+ return $apps{$app} ||= do {
+ local $ENV{MOD_PERL}; # trick Catalyst/CGI.pm etc.
+ Plack::Util::load_psgi $app;
+ };
+}
+
+sub handler {
+ my $r = shift;
+
+ my $psgi = $r->dir_config('psgi_app');
+ my $app = __PACKAGE__->load_app($psgi);
+
+ $r->subprocess_env; # let Apache create %ENV for us :)
+
+ my $env = {
+ %ENV,
+ 'psgi.version' => [ 1, 1 ],
+ 'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
+ 'psgi.input' => $r,
+ 'psgi.errors' => *STDERR,
+ 'psgi.multithread' => Plack::Util::FALSE,
+ 'psgi.multiprocess' => Plack::Util::TRUE,
+ 'psgi.run_once' => Plack::Util::FALSE,
+ 'psgi.streaming' => Plack::Util::TRUE,
+ 'psgi.nonblocking' => Plack::Util::FALSE,
+ };
+
+ my $vpath = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
+ my $location = $r->location || "/";
+ $location =~ s{/$}{};
+ (my $path_info = $vpath) =~ s/^\Q$location\E//;
+
+ $env->{SCRIPT_NAME} = $location;
+ $env->{PATH_INFO} = $path_info;
+
+ my $res = $app->($env);
+
+ if (ref $res eq 'ARRAY') {
+ _handle_response($r, $res);
+ }
+ elsif (ref $res eq 'CODE') {
+ $res->(sub {
+ _handle_response($r, $_[0]);
+ });
+ }
+ else {
+ die "Bad response $res";
+ }
+
+ return Apache2::Const::OK;
+}
+
+sub _handle_response {
+ my ($r, $res) = @_;
+
+ my ($status, $headers, $body) = @{ $res };
+
+ my $hdrs = ($status >= 200 && $status < 300)
+ ? $r->headers_out : $r->err_headers_out;
+
+ Plack::Util::header_iter($headers, sub {
+ my($h, $v) = @_;
+ if (lc $h eq 'content-type') {
+ $r->content_type($v);
+ } elsif (lc $h eq 'content-length') {
+ $r->set_content_length($v);
+ } else {
+ $hdrs->add($h => $v);
+ }
+ });
+
+ $r->status($status);
+
+ if (Scalar::Util::blessed($body) and $body->can('path') and my $path = $body->path) {
+ $r->sendfile($path);
+ } elsif (defined $body) {
+ Plack::Util::foreach($body, sub { $r->print(@_) });
+ $r->rflush;
+ }
+ else {
+ return Plack::Util::inline_object
+ write => sub { $r->print(@_); $r->rflush },
+ close => sub { $r->rflush };
+ }
+
+ return Apache2::Const::OK;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Handler::Apache2 - Apache 2.0 handlers to run PSGI application
+
+=head1 SYNOPSIS
+
+ <Location />
+ SetHandler perl-script
+ PerlResponseHandler Plack::Handler::Apache2
+ PerlSetVar psgi_app /path/to/app.psgi
+ </Location>
+
+ <Perl>
+ use Plack::Handler::Apache2;
+ Plack::Handler::Apache2->preload("/path/to/app.psgi");
+ </Perl>
+
+=head1 DESCRIPTION
+
+This is a handler module to run any PSGI application with mod_perl on Apache 2.x.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack>
+
+=cut
@@ -0,0 +1,124 @@
+package Plack::Handler::CGI;
+use strict;
+use warnings;
+use IO::Handle;
+
+sub new { bless {}, shift }
+
+sub run {
+ my ($self, $app) = @_;
+
+ my $env = {
+ %ENV,
+ 'psgi.version' => [ 1, 1 ],
+ 'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
+ 'psgi.input' => *STDIN,
+ 'psgi.errors' => *STDERR,
+ 'psgi.multithread' => 0,
+ 'psgi.multiprocess' => 1,
+ 'psgi.run_once' => 1,
+ 'psgi.streaming' => 1,
+ 'psgi.nonblocking' => 1,
+ };
+
+ delete $env->{HTTP_CONTENT_TYPE};
+ delete $env->{HTTP_CONTENT_LENGTH};
+ $env->{SCRIPT_NAME} = '' if $env->{SCRIPT_NAME} eq '/';
+ $env->{'HTTP_COOKIE'} ||= $ENV{COOKIE}; # O'Reilly server bug
+
+ my $res = $app->($env);
+ if (ref $res eq 'ARRAY') {
+ $self->_handle_response($res);
+ }
+ elsif (ref $res eq 'CODE') {
+ $res->(sub {
+ $self->_handle_response($_[0]);
+ });
+ }
+ else {
+ die "Bad response $res";
+ }
+}
+
+sub _handle_response {
+ my ($self, $res) = @_;
+
+ *STDOUT->autoflush(1);
+
+ my $hdrs;
+ $hdrs = "Status: $res->[0]\015\012";
+
+ my $headers = $res->[1];
+ while (my ($k, $v) = splice(@$headers, 0, 2)) {
+ $hdrs .= "$k: $v\015\012";
+ }
+ $hdrs .= "\015\012";
+
+ print STDOUT $hdrs;
+
+ my $body = $res->[2];
+ my $cb = sub { print STDOUT $_[0] };
+
+ # inline Plack::Util::foreach here
+ if (ref $body eq 'ARRAY') {
+ for my $line (@$body) {
+ $cb->($line) if length $line;
+ }
+ }
+ elsif (defined $body) {
+ local $/ = \65536 unless ref $/;
+ while (defined(my $line = $body->getline)) {
+ $cb->($line) if length $line;
+ }
+ $body->close;
+ }
+ else {
+ return Plack::Handler::CGI::Writer->new;
+ }
+}
+
+package Plack::Handler::CGI::Writer;
+sub new { bless \do { my $x }, $_[0] }
+sub write { print STDOUT $_[1] }
+sub close { }
+
+package Plack::Handler::CGI;
+
+1;
+__END__
+
+=head1 SYNOPSIS
+
+Want to run PSGI application as a CGI script? Rename .psgi to .cgi and
+change the shebang line like:
+
+ #!/usr/bin/env plackup
+ # rest of the file can be the same as other .psgi file
+
+You can alternatively create a .cgi file that contains something like:
+
+ #!/usr/bin/perl
+ use Plack::Loader;
+ my $app = Plack::Util::load_psgi("/path/to/app.psgi");
+ Plack::Loader->auto->run($app);
+
+This will auto-recognize the CGI environment variable to load this class.
+
+If you really want to explicitly load the CGI handler, you can. For instance
+you might do this when you want to embed a PSGI application server built into
+CGI-compatible perl-based web server:
+
+ use Plack::Handler::CGI;
+ Plack::Handler::CGI->new->run($app);
+
+=head1 DESCRIPTION
+
+This is a handler module to run any PSGI application as a CGI script.
+
+=head1 SEE ALSO
+
+L<Plack>
+
+=cut
+
+
@@ -0,0 +1,307 @@
+package Plack::Handler::FCGI;
+use strict;
+use warnings;
+use constant RUNNING_IN_HELL => $^O eq 'MSWin32';
+
+use Plack::Util;
+use FCGI;
+
+sub new {
+ my $class = shift;
+ my $self = bless {@_}, $class;
+
+ $self->{leave_umask} ||= 0;
+ $self->{keep_stderr} ||= 0;
+ $self->{nointr} ||= 0;
+ $self->{daemonize} ||= $self->{detach}; # compatibility
+ $self->{nproc} ||= 1;
+ $self->{pid} ||= $self->{pidfile}; # compatibility
+ $self->{listen} ||= [ ":$self->{port}" ] if $self->{port}; # compatibility
+ $self->{manager} = 'FCGI::ProcManager' unless exists $self->{manager};
+
+ $self;
+}
+
+sub run {
+ my ($self, $app) = @_;
+
+ my $sock = 0;
+ if ($self->{listen}) {
+ my $old_umask = umask;
+ unless ($self->{leave_umask}) {
+ umask(0);
+ }
+ $sock = FCGI::OpenSocket( $self->{listen}->[0], 100 )
+ or die "failed to open FastCGI socket: $!";
+ unless ($self->{leave_umask}) {
+ umask($old_umask);
+ }
+ }
+ elsif (!RUNNING_IN_HELL) {
+ -S STDIN
+ or die "STDIN is not a socket: specify a listen location";
+ }
+
+ my %env;
+ my $request = FCGI::Request(
+ \*STDIN, \*STDOUT,
+ ($self->{keep_stderr} ? \*STDOUT : \*STDERR), \%env, $sock,
+ ($self->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR),
+ );
+
+ my $proc_manager;
+
+ if ($self->{listen}) {
+ $self->daemon_fork if $self->{detach};
+
+ if ($self->{manager}) {
+ Plack::Util::load_class($self->{manager});
+ $proc_manager = $self->{manager}->new({
+ n_processes => $self->{nproc},
+ pid_fname => $self->{pid},
+ });
+
+ # detach *before* the ProcManager inits
+ $self->daemon_detach if $self->{daemonize};
+
+ $proc_manager->pm_manage;
+ }
+ elsif ($self->{daemonize}) {
+ $self->daemon_detach;
+ }
+ }
+
+ while ($request->Accept >= 0) {
+ $proc_manager && $proc_manager->pm_pre_dispatch;
+
+ my $env = {
+ %env,
+ 'psgi.version' => [1,1],
+ 'psgi.url_scheme' => ($env{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
+ 'psgi.input' => *STDIN,
+ 'psgi.errors' => *STDERR, # FCGI.pm redirects STDERR in Accept() loop, so just print STDERR
+ # print to the correct error handle based on keep_stderr
+ 'psgi.multithread' => Plack::Util::FALSE,
+ 'psgi.multiprocess' => Plack::Util::TRUE,
+ 'psgi.run_once' => Plack::Util::FALSE,
+ 'psgi.streaming' => Plack::Util::TRUE,
+ 'psgi.nonblocking' => Plack::Util::FALSE,
+ };
+
+ # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME if PATH_INFO is empty
+ # http://lists.rawmode.org/pipermail/catalyst/2006-June/008361.html
+ # Thanks to Mark Blythe for this fix
+ if ($env->{SERVER_SOFTWARE} && $env->{SERVER_SOFTWARE} =~ /lighttpd/) {
+ $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME};
+ $env->{SCRIPT_NAME} ||= '';
+ $env->{SERVER_NAME} =~ s/:\d+$//; # cut off port number
+ }
+
+ my $res = Plack::Util::run_app $app, $env;
+
+ if (ref $res eq 'ARRAY') {
+ $self->_handle_response($res);
+ }
+ elsif (ref $res eq 'CODE') {
+ $res->(sub {
+ $self->_handle_response($_[0]);
+ });
+ }
+ else {
+ die "Bad response $res";
+ }
+
+ $proc_manager && $proc_manager->pm_post_dispatch();
+ }
+}
+
+sub _handle_response {
+ my ($self, $res) = @_;
+
+ *STDOUT->autoflush(1);
+
+ my $hdrs;
+ $hdrs = "Status: $res->[0]\015\012";
+
+ my $headers = $res->[1];
+ while (my ($k, $v) = splice @$headers, 0, 2) {
+ $hdrs .= "$k: $v\015\012";
+ }
+ $hdrs .= "\015\012";
+
+ print STDOUT $hdrs;
+
+ my $cb = sub { print STDOUT $_[0] };
+ my $body = $res->[2];
+ if (defined $body) {
+ Plack::Util::foreach($body, $cb);
+ }
+ else {
+ return Plack::Util::inline_object
+ write => $cb,
+ close => sub { };
+ }
+}
+
+sub daemon_fork {
+ require POSIX;
+ fork && exit;
+}
+
+sub daemon_detach {
+ my $self = shift;
+ print "FastCGI daemon started (pid $$)\n";
+ open STDIN, "+</dev/null" or die $!; ## no critic
+ open STDOUT, ">&STDIN" or die $!;
+ open STDERR, ">&STDIN" or die $!;
+ POSIX::setsid();
+}
+
+1;
+
+__END__
+
+=head1 SYNOPSIS
+
+ # Run as a standalone daemon
+ plackup -s FCGI --listen /tmp/fcgi.sock --daemonize --nproc 10
+
+ # Run from your web server like mod_fastcgi
+ #!/usr/bin/env plackup -s FCGI
+ my $app = sub { ... };
+
+ # Roll your own
+ my $server = Plack::Handler::FCGI->new(
+ nproc => $num_proc,
+ listen => $listen,
+ detach => 1,
+ );
+ $server->run($app);
+
+
+=head1 DESCRIPTION
+
+This is a handler module to run any PSGI application as a standalone
+FastCGI daemon or a .fcgi script.
+
+=head2 OPTIONS
+
+=over 4
+
+=item listen
+
+ listen => '/path/to/socket'
+ listen => ':8080'
+
+Listen on a socket path, hostname:port, or :port.
+
+=item port
+
+listen via TCP on port on all interfaces (Same as C<< listen => ":$port" >>)
+
+=item leave-umask
+
+Set to 1 to disable setting umask to 0 for socket open
+
+=item nointr
+
+Do not allow the listener to be interrupted by Ctrl+C
+
+=item nproc
+
+Specify a number of processes for FCGI::ProcManager
+
+=item pid
+
+Specify a filename for the pid file
+
+=item manager
+
+Specify a FCGI::ProcManager sub-class
+
+=item daemonize
+
+Daemonize the process.
+
+=item keep-stderr
+
+Send STDERR to STDOUT instead of the webserver
+
+=back
+
+=head2 WEB SERVER CONFIGURATIONS
+
+=head3 nginx
+
+This is an example nginx configuration to run your FCGI daemon on a
+Unix domain socket and run it at the server's root URL (/).
+
+ http {
+ server {
+ listen 3001;
+ location / {
+ set $script "";
+ set $path_info $uri;
+ fastcgi_pass unix:/tmp/fastcgi.sock;
+ fastcgi_param SCRIPT_NAME $script;
+ fastcgi_param PATH_INFO $path_info;
+ fastcgi_param QUERY_STRING $query_string;
+ fastcgi_param REQUEST_METHOD $request_method;
+ fastcgi_param CONTENT_TYPE $content_type;
+ fastcgi_param CONTENT_LENGTH $content_length;
+ fastcgi_param REQUEST_URI $request_uri;
+ fastcgi_param SEREVR_PROTOCOL $server_protocol;
+ fastcgi_param REMOTE_ADDR $remote_addr;
+ fastcgi_param REMOTE_PORT $remote_port;
+ fastcgi_param SERVER_ADDR $server_addr;
+ fastcgi_param SERVER_PORT $server_port;
+ fastcgi_param SERVER_NAME $server_name;
+ }
+ }
+ }
+
+If you want to host your application in a non-root path, then you
+should mangle this configuration to set the path to C<SCRIPT_NAME> and
+the rest of the path in C<PATH_INFO>.
+
+See L<http://wiki.nginx.org/NginxFcgiExample> for more details.
+
+=head3 Apache mod_fastcgi
+
+You can use C<FastCgiExternalServer> as normal.
+
+ FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/fcgi.sock
+
+See L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html#FastCgiExternalServer> for more details.
+
+=head3 lighttpd
+
+Host in the root path:
+
+ fastcgi.server = ( "" =>
+ ((
+ "socket" => "/tmp/fcgi.sock",
+ "check-local" => "disable"
+ ))
+
+Or in the non-root path over TCP:
+
+ fastcgi.server = ( "/foo" =>
+ ((
+ "host" = "127.0.0.1"
+ "port" = "5000"
+ "check-local" => "disable"
+ ))
+
+Plack::Handler::FCGI has a workaround for lighttpd's weird
+C<SCRIPT_NAME> and C<PATH_INFO> setting when you set I<check-local> to
+C<disable> so both configurations (root or non-root) should work fine.
+
+=cut
+
+=head1 SEE ALSO
+
+L<Plack>
+
+=cut
+
@@ -0,0 +1,87 @@
+package Plack::Handler::HTTP::Server::PSGI;
+use strict;
+
+# for temporary backward compat
+use parent qw( HTTP::Server::PSGI );
+
+sub new {
+ my($class, %args) = @_;
+ bless { %args }, $class;
+}
+
+sub run {
+ my($self, $app) = @_;
+ $self->_server->run($app);
+}
+
+sub _server {
+ my $self = shift;
+ HTTP::Server::PSGI->new(%$self);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Handler::HTTP::Server::PSGI - adapter for HTTP::Server::PSGI
+
+=head1 SYNOPSIS
+
+ % plackup -s HTTP::Server::PSGI \
+ --host 127.0.0.1 --port 9091 --timeout 120
+
+=head1 CONFIGURATIONS
+
+This adapter automatically loads Prefork implementation when
+C<max-workers> is set, but otherwise the default HTTP::Server::PSGI
+which is single process.
+
+=over 4
+
+=item host
+
+Host the server binds to. Defaults to all interfaces.
+
+=item port
+
+Port number the server listens on. Defaults to 8080.
+
+=item timeout
+
+Number of seconds a request times out. Defaults to 300.
+
+=item max-keepalive-reqs
+
+Max requests per a keep-alive request. Defaults to 1, which means Keep-alive is off.
+
+=item keepalive-timeout
+
+Number of seconds a keep-alive request times out. Defaults to 2.
+
+=item max-workers
+
+Number of prefork workers. Defaults to 10.
+
+=item max-reqs-per-child
+
+Number of requests per worker to process. Defaults to 100.
+
+=item max-keepalive-reqs
+
+Max requests per a keep-alive request. Defaults to 100.
+
+=back
+
+=head1 AUTHOR
+
+Kazuho Oku
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack> L<HTTP::Server::PSGI>
+
+=cut
@@ -0,0 +1,61 @@
+package Plack::Handler::HTTP::Server::Simple;
+use strict;
+
+sub new {
+ my($class, %args) = @_;
+ bless {%args}, $class;
+}
+
+sub run {
+ my($self, $app) = @_;
+
+ my $server = Plack::Handler::HTTP::Server::Simple::PSGIServer->new($self->{port});
+ $server->host($self->{host}) if $self->{host};
+ $server->app($app);
+ $server->{_server_ready} = delete $self->{server_ready} || sub {};
+
+ $server->run;
+}
+
+package Plack::Handler::HTTP::Server::Simple::PSGIServer;
+use parent qw(HTTP::Server::Simple::PSGI);
+
+sub print_banner {
+ my $self = shift;
+
+ $self->{_server_ready}->({
+ host => $self->host,
+ port => $self->port,
+ server_software => 'HTTP::Server::Simple::PSGI',
+ });
+}
+
+package Plack::Handler::HTTP::Server::Simple;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Handler::HTTP::Server::Simple - Adapter for HTTP::Server::Simple
+
+=head1 SYNOPSIS
+
+ plackup -s HTTP::Server::Simple --port 9090
+
+=head1 DESCRIPTION
+
+Plack::Handler::HTTP::Server::Simple is an adapter to run PSGI
+applications on L<HTTP::Server::Simple>.
+
+=head1 SEE ALSO
+
+L<Plack>, L<HTTP::Server::Simple::PSGI>
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+
+=cut
@@ -0,0 +1,29 @@
+package Plack::Handler::Standalone;
+use strict;
+use warnings;
+use parent qw( Plack::Handler::HTTP::Server::PSGI );
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Handler::Standalone - adapter for HTTP::Server::PSGI
+
+=head1 SYNOPSIS
+
+ % plackup -s Standalone \
+ --host 127.0.0.1 --port 9091 --timeout 120
+
+=head1 DESCRIPTION
+
+Plack::Handler::Standalone is an adapter for default Plack server
+implementation L<HTTP::Server::PSGI>. This is just an alias for
+L<Plack::Handler::HTTP::Server::PSGI>.
+
+=head1 SEE ALSO
+
+L<Plack::Handler::HTTP::Server::PSGI>
+
+=cut
@@ -0,0 +1,94 @@
+package Plack::Handler;
+use strict;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Handler - Connects PSGI applications and Web servers
+
+=head1 SYNOPSIS
+
+ package Plack::Handler::AwesomeWebServer;
+ sub new {
+ my($class, %opt) = @_;
+ ...
+ return $self;
+ }
+
+ sub run {
+ my($self, $app) = @_;
+ # launch the AwesomeWebServer and run $app in the loop
+ }
+
+ # then from command line
+ plackup -s AwesomeWebServer -a app.psgi
+
+=head1 DESCRIPTION
+
+Plack::Handler defines an adapter (connector) interface to adapt
+L<plackup> and L<Plack::Runner> to various PSGI web servers, such as
+Apache2 for mod_perl and Standalone for L<HTTP::Server::PSGI>.
+
+It is an empty class, and as long as they implement the methods
+defined as an Server adapter interface, they do not need to inherit
+Plack::Handler.
+
+If you write a new handler for existing web servers, I recommend you
+to include the full name of the server module after I<Plack::Handler>
+prefix, like L<Plack::Handler::Net::Server::Coro> if you write a
+handler for L<Net::Server::Coro>. That way you'll be using plackup
+command line option like:
+
+ plackup -s Net::Server::Coro
+
+that makes it easy to figure out which web server you're going to use.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ $server = FooBarServer->new(%args);
+
+Creates a new adapter object. I<%args> can take arbitrary parameters
+to configure server environments but common parameters are:
+
+=over 8
+
+=item port
+
+Port number the server listens to.
+
+=item host
+
+Address the server listens to. Set to undef to listen any interface.
+
+=back
+
+=item run
+
+ $server->run($app);
+
+Starts the server process and when a request comes in, run the PSGI
+application passed in C<$app> in the loop.
+
+=item register_service
+
+ $server->register_service($app);
+
+Optional interface if your server should run in parallel with other
+event loop, particularly L<AnyEvent>. This is the same as C<run> but
+doesn't run the main loop.
+
+=back
+
+=head1 SEE ALSO
+
+rackup
+
+=cut
+
@@ -1,120 +0,0 @@
-package Plack::Loader::Reloadable;
-use strict;
-use warnings;
-use Plack::Util;
-use Try::Tiny;
-use POSIX qw(WNOHANG);
-
-sub wrapper {
- my $self = shift;
- my($meth, @args) = @_;
-
- my $server = Plack::Loader->$meth(@args);
-
- Plack::Util::inline_object
- run => sub { my $app = shift; $self->run_server($server, $app) };
-}
-
-sub new {
- my($class, $path) = @_;
-
- my $self = bless {}, shift;
- $self->{path} = $path;
-
- return $self;
-}
-
-sub run_server {
- my($self, $server, $app) = @_;
-
- my $parent_pid = $$;
- my $monitor_pid = fork;
-
- if (!defined $monitor_pid) {
- die "Can't fork: $!";
- } elsif ($monitor_pid == 0) {
- $self->monitor_loop($parent_pid);
- exit;
- } else {
- start_server: {
- my $server_pid = fork;
-
- if ( !defined $server_pid ) {
- die "Can't fork: $!";
- } elsif ( $server_pid > 0 ) {
- my $restart;
-
- local $SIG{HUP} = sub {
- unless ( $restart++ ) {
- kill TERM => $server_pid;
- }
- };
-
- 1 until waitpid($server_pid, 0) == $server_pid;
-
- if ( $restart ) {
- redo start_server;
- } else {
- kill TERM => $monitor_pid;
- waitpid $monitor_pid, 0;
- exit;
- }
- } else {
- try {
- $server->run($app->());
- } catch {
- warn $_;
- };
- exit;
- }
- }
- }
-}
-
-sub valid_file {
- my($self, $file) = @_;
- $file->{path} !~ m![/\\][\._]|\.bak$|~$!;
-}
-
-sub monitor_loop {
- my ( $self, $parent_pid ) = @_;
-
- my $watcher;
- try {
- # delay load in forked child for stupid FSEvents limitation
- require Filesys::Notify::Simple;
- $watcher = Filesys::Notify::Simple->new($self->{path});
- } catch {
- Carp::carp("Automatic reloading is disabled: $_\n");
- };
-
- return unless $watcher;
-
- while (1) {
- $watcher->wait(sub {
- my @events = @_;
- @events = grep $self->valid_file($_), @events;
- return unless @events;
-
- for my $ev (@events) {
- warn "-- $ev->{path} updated.\n";
- }
-
- warn "Reloading the server...\n";
- kill 'HUP' => $parent_pid;
-
- # no more than one restart per second
- sleep 1;
- });
- }
-}
-
-sub load { shift->wrapper(load => @_) }
-sub auto {
- unless ($ENV{PLACK_SERVER}) {
- warn "Automatic server selection is disabled with plackup -r or -R. Set it with -s or PLACK_SERVER\n";
- }
- shift->wrapper(auto => @_);
-}
-
-1;
@@ -0,0 +1,106 @@
+package Plack::Loader::Restarter;
+use strict;
+use warnings;
+use parent qw(Plack::Loader);
+use Plack::Util;
+use Try::Tiny;
+
+sub new {
+ my($class, $runner) = @_;
+ bless { watch => [] }, $class;
+}
+
+sub preload_app {
+ my($self, $builder) = @_;
+ $self->{builder} = $builder;
+}
+
+sub watch {
+ my($self, @dir) = @_;
+ push @{$self->{watch}}, @dir;
+}
+
+sub _fork_and_start {
+ my($self, $server) = @_;
+
+ my $pid = fork;
+ die "Can't fork: $!" unless defined $pid;
+
+ return $server->run($self->{builder}->()) if $pid == 0; # child
+
+ $self->{pid} = $pid;
+}
+
+sub _kill_child {
+ my $self = shift;
+
+ my $pid = $self->{pid} or return;
+ warn "Killing the existing server (pid:$pid)\n";
+ kill 'TERM' => $pid;
+ waitpid($pid, 0);
+ warn "Successfully killed! Restarting the new server process.\n";
+}
+
+sub valid_file {
+ my($self, $file) = @_;
+ $file->{path} !~ m![/\\][\._]|\.bak$|~$!;
+}
+
+sub run {
+ my($self, $server, $builder) = @_;
+
+ $self->_fork_and_start($server, $builder);
+ return unless $self->{pid};
+
+ require Filesys::Notify::Simple;
+ my $watcher = Filesys::Notify::Simple->new($self->{watch});
+ warn "Watching @{$self->{watch}} for file updates.\n";
+
+ while (1) {
+ my @restart;
+
+ # this is blocking
+ $watcher->wait(sub {
+ my @events = @_;
+ @events = grep $self->valid_file($_), @events;
+ return unless @events;
+
+ @restart = @events;
+ });
+
+ next unless @restart;
+
+ for my $ev (@restart) {
+ warn "-- $ev->{path} updated.\n";
+ }
+
+ $self->_kill_child;
+ $self->_fork_and_start($server, $builder);
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Loader::Restarter - Restarting loader
+
+=head1 SYNOPSIS
+
+ plackup -r -R paths
+
+=head1 DESCRIPTION
+
+Plack::Loader::Restarter is a loader backend that implements C<-r> and
+C<-R> option for the L<plackup> script. It forks the server as a child
+process and the parent watches the directories for file updates, and
+whenever it receives the notification, kills the child server and
+restart.
+
+=head1 SEE ALSO
+
+L<Plack::Runner>, L<Catalyst::Restarter>
+
+=cut
@@ -0,0 +1,98 @@
+package Plack::Loader::Shotgun;
+use strict;
+use parent qw(Plack::Loader);
+use Storable;
+use Try::Tiny;
+use Plack::Middleware::BufferedStreaming;
+
+sub preload_app {
+ my($self, $builder) = @_;
+ $self->{builder} = sub { Plack::Middleware::BufferedStreaming->wrap($builder->()) };
+}
+
+sub run {
+ my($self, $server) = @_;
+
+ my $app = sub {
+ my $env = shift;
+
+ pipe my $read, my $write;
+
+ my $pid = fork;
+ if ($pid) {
+ # parent
+ close $write;
+ my $res = Storable::thaw(join '', <$read>);
+ close $read;
+ waitpid($pid, 0);
+
+ return $res;
+ } else {
+ # child
+ close $read;
+
+ my $res;
+ try {
+ $env->{'psgi.streaming'} = 0;
+ $res = $self->{builder}->()->($env);
+ my @body;
+ Plack::Util::foreach($res->[2], sub { push @body, $_[0] });
+ $res->[2] = \@body;
+ } catch {
+ $env->{'psgi.errors'}->print($_);
+ $res = [ 500, [ "Content-Type", "text/plain" ], [ "Internal Server Error" ] ];
+ };
+
+ print {$write} Storable::freeze($res);
+ close $write;
+ exit;
+ }
+ };
+
+ $server->run($app);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Loader::Shotgun - forking implementation of plackup
+
+=head1 SYNOPSIS
+
+ plackup -L Shotgun
+
+=head1 DESCRIPTIOM
+
+Shotgun loader delays the compilation and execution of your
+application until the runtime. When a new request comes in, this forks
+a new child, compiles your code and runs the application.
+
+This should be an ultimate alternative solution when reloading with
+L<Plack::Middleware::Refresh> doesn't work, or plackup's default C<-r>
+filesystem watcher causes problems. I can imagine this is useful for
+applications which expects their application is only evaluated once
+(like in-file templates) or on operating systems with broken fork
+implementation, etc.
+
+This is much like good old CGI's fork and run but you don't need a web
+server, and there's a benefit of preloading modules that are not
+likely to change. For instance if you develop a web application using
+Moose and DBIx::Class,
+
+ plackup -MMoose -MDBIx::Class -L Shotgun yourapp.psgi
+
+would preload those modules and only re-evaluates your code in every
+request.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa with an inspiration from L<http://github.com/rtomayko/shotgun>
+
+=head1 SEE ALSO
+
+L<plackup>
+
+=cut
@@ -2,18 +2,58 @@ package Plack::Loader;
use strict;
use Carp ();
use Plack::Util;
+use Try::Tiny;
+
+sub new {
+ my $class = shift;
+ bless {}, $class;
+}
+
+sub watch {
+ # do nothing. Override in subclass
+}
sub auto {
- my($class, %args) = @_;
+ my($class, @args) = @_;
+
+ my $backend = $class->guess
+ or Carp::croak("Couldn't auto-guess server server implementation. Set it with PLACK_SERVER");
- my $server = $class->guess
- or Carp::croak("Couldn't auto-guess server serverementation. Set it with PLACK_SERVER");
- Plack::Util::load_class($server, "Plack::Server")->new(%args);
+ my $server = try {
+ $class->load($backend, @args);
+ } catch {
+ warn "Autoloading '$backend' backend failed. Falling back to the Standalone. ",
+ "(You might need to install Plack::Handler::$backend from CPAN)\n"
+ if $ENV{PLACK_DEV} && $ENV{PLACK_DEV} eq 'development';
+ $class->load('Standalone' => @args);
+ };
+
+ return $server;
}
sub load {
my($class, $server, @args) = @_;
- Plack::Util::load_class($server, "Plack::Server")->new(@args);
+
+ my($server_class, $error);
+ for my $prefix (qw( Plack::Handler Plack::Server )) {
+ try {
+ $server_class = Plack::Util::load_class($server, $prefix);
+ } catch {
+ $error ||= $_;
+ };
+ last if $server_class;
+ }
+
+ if ($server_class) {
+ $server_class->new(@args);
+ } else {
+ die $error;
+ }
+}
+
+sub preload_app {
+ my($self, $builder) = @_;
+ $self->{app} = $builder->();
}
sub guess {
@@ -26,7 +66,7 @@ sub guess {
} elsif ($ENV{GATEWAY_INTERFACE}) {
return "CGI";
} elsif (exists $INC{"AnyEvent.pm"}) {
- return "AnyEvent";
+ return "Twiggy";
} elsif (exists $INC{"Coro.pm"}) {
return "Coro";
} elsif (exists $INC{"POE.pm"}) {
@@ -38,6 +78,11 @@ sub guess {
}
}
+sub run {
+ my($self, $server, $builder) = @_;
+ $server->run($self->{app});
+}
+
1;
__END__
@@ -57,7 +102,7 @@ Plack::Loader - (auto)load Plack Servers
=head1 DESCRIPTION
-Plack::Loader is a factory class to load one of Plack::Server subclasses based on the environment.
+Plack::Loader is a factory class to load one of Plack::Handler subclasses based on the environment.
=head1 AUTOLOADING
@@ -81,8 +126,8 @@ use the corresponding server implementation.
=item %INC
-If one of L<AnyEvent>, L<Coro> or L<Danga::Socket> is loaded, the
-relevant implementation will be loaded.
+If one of L<AnyEvent>, L<Coro>, L<POE> or L<Danga::Socket> is loaded,
+the relevant implementation will be loaded.
=back
@@ -46,7 +46,7 @@ sub log_line {
my($block, $type) = @_;
if ($type eq 'i') {
$block =~ s/-/_/;
- return $env->{"HTTP_" . uc($block)} || "-";
+ return _safe($env->{"HTTP_" . uc($block)}) || "-";
} elsif ($type eq 'o') {
return scalar $h->get($block) || "-";
} elsif ($type eq 't') {
@@ -59,11 +59,11 @@ sub log_line {
my %char_handler = (
'%' => sub { '%' },
- h => sub { $env->{HTTP_X_FORWARDED_FOR} || $env->{REMOTE_ADDR} || '-' },
+ h => sub { $env->{REMOTE_ADDR} || '-' },
l => sub { '-' },
u => sub { $env->{REMOTE_USER} || '-' },
t => sub { "[" . $strftime->("%d/%b/%Y %H:%M:%S", localtime) . "]" },
- r => sub { $env->{REQUEST_METHOD} . " " . $env->{REQUEST_URI} .
+ r => sub { _safe($env->{REQUEST_METHOD}) . " " . _safe($env->{REQUEST_URI}) .
" " . $env->{SERVER_PROTOCOL} },
s => sub { $status },
b => sub { $opts->{content_length} || $h->get('Content-Length') || "-" },
@@ -95,6 +95,14 @@ sub log_line {
return $fmt . "\n";
}
+sub _safe {
+ my $string = shift;
+ $string =~ s/([^[:print:]])/"\\x" . unpack("H*", $1)/eg
+ if defined $string;
+ $string;
+}
+
+
__END__
=for stopwords
@@ -0,0 +1,73 @@
+package Plack::Middleware::BufferedStreaming;
+use strict;
+no warnings;
+use Carp;
+use Plack::Util;
+use Scalar::Util qw(weaken);
+use parent qw(Plack::Middleware);
+
+sub call {
+ my ( $self, $env ) = @_;
+
+ my $caller_supports_streaming = $env->{'psgi.streaming'};
+ $env->{'psgi.streaming'} = Plack::Util::TRUE;
+
+ my $res = $self->app->($env);
+ return $res if $caller_supports_streaming;
+
+ if ( ref($res) eq 'CODE' ) {
+ my $ret;
+
+ $res->(sub {
+ my $write = shift;
+
+ if ( @$write == 2 ) {
+ my @body;
+
+ $ret = [ @$write, \@body ];
+
+ return Plack::Util::inline_object(
+ write => sub { push @body, $_[0] },
+ close => sub { },
+ );
+ } else {
+ $ret = $write;
+ return;
+ }
+ });
+
+ return $ret;
+ } else {
+ return $res;
+ }
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::BufferedStreaming - Enable buffering for non-streaming aware servers
+
+=head1 SYNOPSIS
+
+ enable "BufferedStreaming";
+
+=head1 DESCRIPTION
+
+Plack::Middleware::BufferedStreaming is a PSGI middleware component
+that wraps the application that uses C<psgi.streaming> interface to
+run on the servers that do not support the interface, by buffering the
+writer output to a temporary buffer.
+
+This middleware doesn't do anything and bypass the application if the
+server supports C<psgi.streaming> interface.
+
+=head1 AUTHOR
+
+Yuval Kogman
+
+Tatsuhiko Miyagawa
+
+=cut
@@ -38,7 +38,7 @@ Plack::Middleware::ContentLength - Adds Content-Length header automatically
$app;
}
- # Or in Plack::Server::*
+ # Or in Plack::Handler::*
$app = Plack::Middleware::ContentLength->wrap($app);
=head1 DESCRIPTION
@@ -0,0 +1,108 @@
+package Plack::Middleware::HTTPExceptions;
+use strict;
+use parent qw(Plack::Middleware);
+
+use Carp ();
+use Try::Tiny;
+use Scalar::Util 'blessed';
+use HTTP::Status ();
+
+sub call {
+ my($self, $env) = @_;
+
+ my $res = try {
+ $self->app->($env);
+ } catch {
+ $self->transform_error($_);
+ };
+
+ return $res if ref $res eq 'ARRAY';
+
+ return sub {
+ my $respond = shift;
+
+ my $writer;
+ try {
+ $res->(sub { return $writer = $respond->(@_) });
+ } catch {
+ if ($writer) {
+ Carp::cluck $_;
+ $writer->close;
+ } else {
+ my $res = $self->transform_error($_);
+ $respond->($res);
+ }
+ };
+ };
+}
+
+sub transform_error {
+ my($self, $e) = @_;
+
+ my($code, $message);
+ if (blessed $e && $e->can('code')) {
+ $code = $e->code;
+ $message =
+ $e->can('as_string') ? $e->as_string :
+ overload::Method($e, '""') ? "$e" : undef;
+ } else {
+ $code = 500;
+ }
+
+ if ($code !~ /^[3-5]\d\d$/) {
+ die $e; # rethrow
+ }
+
+ $message ||= HTTP::Status::status_message($code);
+
+ return [ $code, [ 'Content-Type' => 'text/plain', 'Content-Length' => length($message) ], [ $message ] ];
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::HTTPExceptions - Catch HTTP exceptions
+
+=head1 SYNOPSIS
+
+ my $app = sub {
+ # ...
+ MyHTTPError::BadGateway->throw;
+ };
+
+ builder {
+ enable "HTTPExceptions";
+ $app;
+ };
+
+=head1 DESCRIPTION
+
+Plack::Middleware::HTTPExceptions is a PSGI middleware component to
+catch exceptions from applicaitions that can be translated into HTTP
+status code.
+
+Your application is supposed to throw an object that implements
+C<code> method which returns the HTTP status code such as 501 or
+404. This middleware catches them and creates a valid response out of
+the code.
+
+The exception object may also implement C<as_string>, or overload the
+stringification, to represent the text of the error, which defaults to
+the status message of error codes, such as I<Service Unavailable> for
+C<503>.
+
+All the other errors that can't be translated into HTTP errors are
+just rethrown to the outer frame.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+paste.httpexceptions
+
+=cut
@@ -9,18 +9,22 @@ sub call {
my $res = $self->app->($env);
$self->response_cb($res, sub {
my $res = shift;
- if (defined $res->[2] && ref $res->[2] eq 'ARRAY') {
- my $h = Plack::Util::headers($res->[1]);
- if ($h->get('Content-Type') =~ m!/(?:json|javascript)! &&
+
+ my $h = Plack::Util::headers($res->[1]);
+ if ($h->get('Content-Type') =~ m!/(?:json|javascript)! &&
$env->{QUERY_STRING} =~ /(?:^|&)callback=([^&]+)/) {
- # TODO: support callback params other than 'callback'
- my $cb = URI::Escape::uri_unescape($1);
- if ($cb =~ /^[\w\.\[\]]+$/) {
- my $jsonp = "$cb($res->[2][0])";
- $res->[2] = [ $jsonp ];
- $h->set('Content-Length', length $jsonp);
- $h->set('Content-Type', 'text/javascript');
- }
+ # TODO: support callback params other than 'callback'
+ my $cb = URI::Escape::uri_unescape($1);
+
+ if ($cb =~ /^[\w\.\[\]]+$/) {
+ $h->set('Content-Type', 'text/javascript');
+
+ # The filter to transform the body into a JSONP response.
+ my $isnt_first = 0;
+ return sub {
+ return ( $isnt_first++ ? '' : "$cb(" )
+ . ( defined $_[0] ? $_[0] : ')' );
+ };
}
}
});
@@ -40,13 +44,15 @@ Plack::Middleware::JSONP wraps JSON response, which has Content-Type
value either C<text/javascript> or C<application/json> as a JSONP
response which is specified with the C<callback> query parameter.
+Since this middleware removes the Content-Length header to rewrite the content body, you may also want to enable Plack::Middleware::ContentLength.
+
=head1 AUTHOR
Tatsuhiko Miyagawa
=head1 SEE ALSO
-L<Plack>
+L<Plack> L<Plack::Middleware::ContentLength>
=cut
@@ -44,8 +44,8 @@ sub validate_env {
unless (!defined($env->{'SERVER_PROTOCOL'}) || $env->{'SERVER_PROTOCOL'} =~ m{^HTTP/1.\d$}) {
Carp::croak('invalid SERVER_PROTOCOL');
}
- for my $param (qw/version url_scheme input errors/) {
- unless (defined($env->{"psgi.$param"})) {
+ for my $param (qw/version url_scheme input errors multithread multiprocess/) {
+ unless (exists $env->{"psgi.$param"}) {
Carp::croak("missing psgi.$param");
}
}
@@ -58,6 +58,19 @@ sub validate_env {
unless ($env->{'psgi.url_scheme'} =~ /^https?$/) {
Carp::croak('psgi.version should be "http" or "https"');
}
+ if ($env->{"psgi.version"}->[1] == 1) { # 1.1
+ for my $param (qw(streaming nonblocking run_once)) {
+ unless (exists $env->{"psgi.$param"}) {
+ Carp::croak("missing psgi.$param");
+ }
+ }
+ }
+ if ($env->{HTTP_CONTENT_TYPE}) {
+ Carp::croak('HTTP_CONTENT_TYPE should not exist');
+ }
+ if ($env->{HTTP_CONTENT_LENGTH}) {
+ Carp::croak('HTTP_CONTENT_LENGTH should not exist');
+ }
}
sub validate_res {
@@ -0,0 +1,88 @@
+package Plack::Middleware::Log4perl;
+use strict;
+use parent qw(Plack::Middleware);
+use Plack::Util::Accessor qw(category logger conf);
+use Carp ();
+
+sub prepare_app {
+ my $self = shift;
+
+ if ($self->conf) {
+ require Log::Log4perl;
+ Log::Log4perl::init($self->conf);
+ }
+
+ $self->logger( Log::Log4perl->get_logger($self->category || '') );
+}
+
+sub call {
+ my($self, $env) = @_;
+
+ $env->{'psgix.logger'} = sub {
+ my $args = shift;
+ my $level = $args->{level};
+ $self->logger->$level($args->{message});
+ };
+
+ $self->app->($env);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::Log4perl - Uses Log::Log4perl to configure logger
+
+=head1 SYNOPSIS
+
+ use Log::Log4perl;
+
+ Log::Log4perl::init('/path/to/log4perl.conf');
+
+ builder {
+ enable "Log4perl", category => "plack";
+ $app;
+ }
+
+ # in log4perl.conf
+ log4perl.logger.plack = INFO, Logfile
+ log4perl.appender.Logfile = Log::Log4perl::Appender::File
+ log4perl.appender.Logfile.filename = /path/to/logfile.log
+ log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout
+
+ # Or let middleware to configure log4perl
+ enable "Log4perl", category => "plack", conf => '/path/to/log.conf';
+
+=head1 DESCRIPTION
+
+Log4perl is a Plack::Middleware component that allows you to use
+L<Log::Log4perl> to configure logging object.
+
+=head1 CONFIGURATION
+
+=over 4
+
+=item category
+
+The log4perl category to send logs to. Defaults to C<''> which means
+it send to the root logger.
+
+=item conf
+
+The configuration file path (or a scalar ref containing the config
+string) for Log::Log4perl to automatically configure.
+
+=back
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Log::Dispatch>
+
+=cut
+
@@ -0,0 +1,80 @@
+package Plack::Middleware::LogDispatch;
+use strict;
+use parent qw(Plack::Middleware);
+use Plack::Util::Accessor qw(logger);
+use Carp ();
+
+sub prepare_app {
+ my $self = shift;
+ unless ($self->logger) {
+ Carp::croak "logger is not defined";
+ }
+}
+
+sub call {
+ my($self, $env) = @_;
+
+ $env->{'psgix.logger'} = sub {
+ my $args = shift;
+ $args->{level} = 'critical' if $args->{level} eq 'fatal';
+ $self->logger->log(%$args);
+ };
+
+ $self->app->($env);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::LogDispatch - Uses Log::Dispatch to configure logger
+
+=head1 SYNOPSIS
+
+ use Log::Dispatch;
+
+ my $logger = Log::Dispatch->new;
+ $logger->add( Log::Dispatch::File->new(...) );
+ $logger->add( Log::Dispatch::DesktopNotification->new(...) );
+
+ builder {
+ enable "LogDispatch", logger => $logger;
+ $app;
+ }
+
+ # use with Log::Dispatch::Config
+ use Log::Dispatch::Config;
+ Log::Dispatch::Config->configure('/path/to/log.conf');
+
+ builder {
+ enable "LogDispatch", logger => Log::Dispatch::Config->instance;
+ ...
+ }
+
+=head1 DESCRIPTION
+
+LogDispatch is a Plack::Middleware component that allows you to use
+L<Log::Dispatch> to configure logging object.
+
+=head1 CONFIGURATION
+
+=over 4
+
+=item logger
+
+Log::Dispatch object to send logs to. Required.
+
+=back
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Log::Dispatch>
+
+=cut
+
@@ -0,0 +1,32 @@
+package Plack::Middleware::NullLogger;
+use strict;
+
+sub call {
+ my($self, $env) = @_;
+ $env->{'psgix.logger'} = sub { };
+ $self->app->($env);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::NullLogger - Send logs to /dev/null
+
+=head1 SYNOPSIS
+
+ enable "NullLogger";
+
+=head1 DESCRIPTIOM
+
+NullLogger is a middleware component that receives logs and does
+nothing but discarding them. Might be useful to shut up all the logs
+from frameworks in one shot.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=cut
@@ -0,0 +1,133 @@
+package Plack::Middleware::Recursive;
+use strict;
+use parent qw(Plack::Middleware);
+
+use Try::Tiny;
+use Scalar::Util qw(blessed);
+
+open my $null_io, "<", \"";
+
+sub call {
+ my($self, $env) = @_;
+
+ $env->{'plack.recursive.include'} = $self->recurse_callback($env, 1);
+
+ my $res = try {
+ $self->app->($env);
+ } catch {
+ if (blessed $_ && $_->isa('Plack::Recursive::ForwardRequest')) {
+ return $self->recurse_callback($env)->($_->path);
+ }
+ };
+
+ return $res if ref $res eq 'ARRAY';
+
+ return sub {
+ my $respond = shift;
+
+ my $writer;
+ try {
+ $res->(sub { return $writer = $respond->(@_) });
+ } catch {
+ if (!$writer && blessed $_ && $_->isa('Plack::Recursive::ForwardRequest')) {
+ $res = $self->recurse_callback($env)->($_->path);
+ return ref $res eq 'CODE' ? $res->($respond) : $respond->($res);
+ } else {
+ die $_;
+ }
+ };
+ };
+}
+
+sub recurse_callback {
+ my($self, $env, $include) = @_;
+
+ my $old_path_info = $env->{PATH_INFO};
+
+ return sub {
+ my $new_path_info = shift;
+ my($path, $query) = split /\?/, $new_path_info, 2;
+
+ Scalar::Util::weaken($env);
+
+ $env->{PATH_INFO} = $path;
+ $env->{QUERY_STRING} = $query;
+ $env->{REQUEST_METHOD} = 'GET';
+ $env->{CONTENT_LENGTH} = 0;
+ $env->{CONTENT_TYPE} = '';
+ $env->{'psgi.input'} = $null_io;
+ push @{$env->{'plack.recursive.old_path_info'}}, $old_path_info;
+
+ $include ? $self->app->($env) : $self->call($env);
+ };
+}
+
+package Plack::Recursive::ForwardRequest;
+use overload q("") => \&as_string, fallback => 1;
+
+sub new {
+ my($class, $path) = @_;
+ bless { path => $path }, $class;
+}
+
+sub path { $_[0]->{path} }
+
+sub throw {
+ my($class, @args) = @_;
+ die $class->new(@args);
+}
+
+sub as_string {
+ my $self = shift;
+ return "Forwarding to $self->{path}: Your application should be wrapped with Plack::Middleware::Recursive.";
+}
+
+package Plack::Middleware::Recursive;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::Recursive - Allows PSGI apps to include or forward requests recursively
+
+=head1 SYNOPSIS
+
+ # with Builder
+ enable "Recursive";
+
+ # in apps
+ my $res = $env->{'plack.recursive.include'}->("/new_path");
+
+ # Or, use exceptions
+ my $app = sub {
+ # ...
+ Plack::Recursive::ForwardRequest->throw("/new_path");
+ };
+
+=head1 DESCRIPTION
+
+Plack::Middleware::Recursive allows PSGI applications to recursively
+include or forward requests to other paths. Applications can make use
+of callbacks stored in C<< $env->{'plack.recursive.include'} >> to
+I<include> another path to get the response (whether it's an array ref
+or a code ref depending on your application), or throw an exception
+Plack::Recursive::ForwardRequest anywhere in the code to I<forward>
+the current request (i.e. abort the current and redo the request).
+
+=head1 AUTHORS
+
+Tatsuhiko Miyagawa
+
+Masahiro Honma
+
+=head1 SEE ALSO
+
+L<Plack> L<Plack::Middleware::HTTPExceptions>
+
+The idea, code and interface are stolen from Rack::Recursive and paste.recursive.
+
+=cut
+
+
@@ -0,0 +1,65 @@
+package Plack::Middleware::Refresh;
+use strict;
+use parent qw(Plack::Middleware);
+use Module::Refresh;
+use Plack::Util::Accessor qw(last cooldown);
+
+sub prepare_app {
+ my $self = shift;
+ $self->cooldown(10) unless defined $self->cooldown;
+ $self->last(time - $self->cooldown);
+}
+
+sub call {
+ my($self, $env) = @_;
+
+ if (time > $self->last + $self->cooldown) {
+ Module::Refresh->refresh;
+ $self->last(time);
+ }
+
+ $self->app->($env);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::Refresh - Refresh all modules in %INC
+
+=head1 SYNOPSIS
+
+ enable "Refresh", cooldown => 3;
+ $app;
+
+=head1 DESCRIPTION
+
+This is I<yet another> approach to refresh modules in C<%INC> during
+the development cycle, without the need to have a forking process to
+watch for filesystem updates. This middleware, in a request time,
+compares the last refresh time and the current time and if the
+difference is bigger than I<cooldown> seconds which defaults to 10,
+call L<Module::Refresh> to reload all Perl modules in C<%INC> if the
+files have been modified.
+
+Note that this only reloads modules and not other files such as
+templates.
+
+This middleware is quite similar to what Rack::Reoader does. If you
+have issues with this reloading technique, for instance when you have
+in-file templates that needs to be recompiled, or Moose classes that
+has C<make_immutable>, take a look at L<plackup>'s default -r option
+or L<Plack::Loader::Shotgun> instead.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Module::Refresh> Rack::Reloader
+
+=cut
+
@@ -0,0 +1,64 @@
+package Plack::Middleware::SimpleLogger;
+use strict;
+use parent qw(Plack::Middleware);
+use Plack::Util::Accessor qw(level);
+use POSIX;
+
+# Should this be in Plack::Util?
+my $i = 0;
+my %level_numbers = map { $_ => $i++ } qw(debug info warn error fatal);
+
+sub call {
+ my($self, $env) = @_;
+
+ my $min = $level_numbers{ $self->level || "debug" };
+
+ $env->{'psgix.logger'} = sub {
+ my $args = shift;
+
+ if ($level_numbers{$args->{level}} >= $min) {
+ $env->{'psgi.errors'}->print($self->format_message($args->{level}, $args->{message}));
+ }
+ };
+
+ $self->app->($env);
+}
+
+sub format_time {
+ my $old_locale = POSIX::setlocale(&POSIX::LC_ALL);
+ POSIX::setlocale(&POSIX::LC_ALL, 'en');
+ my $out = POSIX::strftime(@_);
+ POSIX::setlocale(&POSIX::LC_ALL, $old_locale);
+ return $out;
+}
+
+sub format_message {
+ my($self, $level, $message) = @_;
+
+ my $time = format_time("%Y-%m-%dT%H:%M:%S", localtime);
+ sprintf "%s [%s #%d] %s: %s\n", uc substr($level, 0, 1), $time, $$, uc $level, $message;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Middleware::SimpleLogger - Simple logger that prints to psgi.errors
+
+=head1 SYNOPSIS
+
+ enable "SimpleLogger", level => "warn";
+
+=head1 DESCRIPTION
+
+SimpleLogger is a middleware component that formats the log message
+with information such as the time and PID and prints them to
+I<psgi.errors> stream, which is mostly STDERR or server log output.
+
+=head1 AUTHOR
+
+Tatsuhiko Miyagawa
+
+=cut
@@ -2,8 +2,6 @@ package Plack::Middleware::StackTrace;
use strict;
use warnings;
use parent qw/Plack::Middleware/;
-use Plack;
-use Plack::Util;
use Devel::StackTrace;
use Devel::StackTrace::AsHTML;
use Try::Tiny;
@@ -20,18 +20,12 @@ sub _handle_static {
my($self, $env) = @_;
my $path_match = $self->path or return;
+ my $path = $env->{PATH_INFO};
- my $path = do {
- my $matched;
- local $_ = $env->{PATH_INFO};
- if (ref $path_match eq 'CODE') {
- $matched = $path_match->($_);
- } else {
- $matched = $_ =~ $path_match;
- }
+ for ($path) {
+ my $matched = 'CODE' eq ref $path_match ? $path_match->($_) : $_ =~ $path_match;
return unless $matched;
- $_;
- } or return;
+ }
$self->{file} ||= Plack::App::File->new({ root => $self->root || '.', encoding => $self->encoding });
local $env->{PATH_INFO} = $path; # rewrite PATH
@@ -1,50 +1,15 @@
package Plack::Middleware::Writer;
use strict;
-no warnings;
-use Carp;
-use Plack::Util;
-use Scalar::Util qw(weaken);
-use parent qw(Plack::Middleware);
+use parent qw(Plack::Middleware::BufferedStreaming);
-sub call {
- my ( $self, $env ) = @_;
-
- my $caller_supports_streaming = $env->{'psgi.streaming'};
- $env->{'psgi.streaming'} = Plack::Util::TRUE;
-
- my $res = $self->app->($env);
- return $res if $caller_supports_streaming;
-
- if ( ref($res) eq 'CODE' ) {
- my $ret;
-
- $res->(sub {
- my $write = shift;
-
- if ( @$write == 2 ) {
- my @body;
-
- $ret = [ @$write, \@body ];
-
- return Plack::Util::inline_object(
- write => sub { push @body, $_[0] },
- close => sub { },
- );
- } else {
- $ret = $write;
- return;
- }
- });
+__END__
- return $ret;
- } else {
- return $res;
- }
-}
+=head1 NAME
+Plack::Middleware::Writer - DEPRECATED
-# ex: set sw=4 et:
+=head1 SEE ALSO
-__PACKAGE__
+L<Plack::Middleware::BufferedStreaming>
-__END__
+=cut
@@ -23,61 +23,6 @@ sub wrap {
return $self->to_app;
}
-sub response_cb {
- my($self, $res, $cb) = @_;
-
- my $body_filter = sub {
- my($cb, $res) = @_;
- my $filter_cb = $cb->($res);
- # If response_cb returns a callback, treat it as a $body filter
- if (defined $filter_cb && ref $filter_cb eq 'CODE') {
- Plack::Util::header_remove($res->[1], 'Content-Length');
- if (defined $res->[2]) {
- if (ref $res->[2] eq 'ARRAY') {
- for my $line (@{$res->[2]}) {
- $line = $filter_cb->($line);
- }
- # Send EOF.
- push @{ $res->[2] }, $filter_cb->( undef );
- } else {
- my $body = $res->[2];
- my $getline = sub { $body->getline };
- $res->[2] = Plack::Util::inline_object
- getline => sub { $filter_cb->($getline->()) },
- close => sub { $body->close };
- }
- } else {
- return $filter_cb;
- }
- }
- };
-
- if (ref $res eq 'ARRAY') {
- $body_filter->($cb, $res);
- return $res;
- } elsif (ref $res eq 'CODE') {
- return sub {
- my $respond = shift;
- $res->(sub {
- my $res = shift;
- my $filter_cb = $body_filter->($cb, $res);
- if ($filter_cb) {
- my $writer = $respond->($res);
- if ($writer) {
- return Plack::Util::inline_object
- write => sub { $writer->write($filter_cb->(@_)) },
- close => sub { $writer->write($filter_cb->(undef)); $writer->close };
- }
- } else {
- return $respond->($res);
- }
- });
- };
- }
-
- return $res;
-}
-
1;
__END__
@@ -0,0 +1,96 @@
+package Plack::Request::Upload;
+use strict;
+use warnings;
+use Carp ();
+
+sub new {
+ my($class, %args) = @_;
+
+ bless {
+ headers => $args{headers},
+ tempname => $args{tempname},
+ size => $args{size},
+ filename => $args{filename},
+ }, $class;
+}
+
+sub filename { $_[0]->{filename} }
+sub headers { $_[0]->{headers} }
+sub size { $_[0]->{size} }
+sub tempname { $_[0]->{tempname} }
+sub path { $_[0]->{tempname} }
+
+sub content_type {
+ my $self = shift;
+ $self->{headers}->content_type(@_);
+}
+
+sub type { shift->content_type(@_) }
+
+sub basename {
+ my $self = shift;
+ unless (defined $self->{basename}) {
+ require File::Spec::Unix;
+ my $basename = $self->{filename};
+ $basename =~ s|\\|/|g;
+ $basename = ( File::Spec::Unix->splitpath($basename) )[2];
+ $basename =~ s|[^\w\.-]+|_|g;
+ $self->{basename} = $basename;
+ }
+ $self->{basename};
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Request::Upload - handles file upload requests
+
+=head1 SYNOPSIS
+
+ # $req is Plack::Request
+ my $upload = $req->uploads->{field};
+
+ $upload->size;
+ $upload->path;
+ $upload->content_type;
+ $upload->basename;
+
+=head1 METHODS
+
+=over 4
+
+=item size
+
+Returns the size of Uploaded file.
+
+=item path
+
+Returns the path to the temporary file where uploaded file is saved.
+
+=item content_type
+
+Returns the content type of the uploaded file.
+
+=item filename
+
+Returns the original filename in the client.
+
+=item basename
+
+Returns basename for "filename".
+
+=back
+
+=head1 AUTHORS
+
+Kazuhiro Osawa
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack::Request>, L<Catalyst::Request::Upload>
+
+=cut
@@ -0,0 +1,677 @@
+package Plack::Request;
+use strict;
+use warnings;
+use 5.008_001;
+our $VERSION = '0.9911';
+$VERSION = eval $VERSION;
+
+use HTTP::Headers;
+use Carp ();
+use Hash::MultiValue;
+use HTTP::Body;
+
+use Plack::Request::Upload;
+use Plack::TempBuffer;
+use URI;
+use URI::Escape ();
+
+sub _deprecated {
+ my $alt = shift;
+ my $method = (caller(1))[3];
+ Carp::carp("$method is deprecated. Use '$alt' instead.");
+}
+
+sub new {
+ my($class, $env) = @_;
+ Carp::croak(q{$env is required})
+ unless defined $env && ref($env) eq 'HASH';
+
+ bless { env => $env }, $class;
+}
+
+sub env { $_[0]->{env} }
+
+sub address { $_[0]->env->{REMOTE_ADDR} }
+sub remote_host { $_[0]->env->{REMOTE_HOST} }
+sub protocol { $_[0]->env->{SERVER_PROTOCOL} }
+sub method { $_[0]->env->{REQUEST_METHOD} }
+sub port { $_[0]->env->{SERVER_PORT} }
+sub user { $_[0]->env->{REMOTE_USER} }
+sub request_uri { $_[0]->env->{REQUEST_URI} }
+sub path_info { $_[0]->env->{PATH_INFO} }
+sub path { $_[0]->env->{PATH_INFO} || '/' }
+sub script_name { $_[0]->env->{SCRIPT_NAME} }
+sub scheme { $_[0]->env->{'psgi.url_scheme'} }
+sub secure { $_[0]->scheme eq 'https' }
+sub body { $_[0]->env->{'psgi.input'} }
+sub input { $_[0]->env->{'psgi.input'} }
+
+sub session { $_[0]->env->{'psgix.session'} }
+sub session_options { $_[0]->env->{'psgix.session.options'} }
+sub logger { $_[0]->env->{'psgix.logger'} }
+
+sub cookies {
+ my $self = shift;
+
+ return {} unless $self->env->{HTTP_COOKIE};
+
+ # HTTP_COOKIE hasn't changed: reuse the parsed cookie
+ if ( $self->env->{'plack.cookie.parsed'}
+ && $self->env->{'plack.cookie.string'} eq $self->env->{HTTP_COOKIE}) {
+ return $self->env->{'plack.cookie.parsed'};
+ }
+
+ $self->env->{'plack.cookie.string'} = $self->env->{HTTP_COOKIE};
+
+ my %results;
+ my @pairs = split "[;,] ?", $self->env->{'plack.cookie.string'};
+ for my $pair ( @pairs ) {
+ # trim leading trailing whitespace
+ $pair =~ s/^\s+//; $pair =~ s/\s+$//;
+
+ my ($key, $value) = map URI::Escape::uri_unescape($_), split( "=", $pair, 2 );
+
+ # Take the first one like CGI.pm or rack do
+ $results{$key} = $value unless exists $results{$key};
+ }
+
+ $self->env->{'plack.cookie.parsed'} = \%results;
+}
+
+sub query_parameters {
+ my $self = shift;
+ $self->env->{'plack.request.query'} ||= Hash::MultiValue->new($self->uri->query_form);
+}
+
+sub content {
+ my $self = shift;
+
+ unless ($self->env->{'psgix.input.buffered'}) {
+ $self->_parse_request_body;
+ }
+
+ my $fh = $self->input or return '';
+ $fh->read(my($content), $self->content_length || 0, 0);
+ $fh->seek(0, 0);
+
+ return $content;
+}
+
+sub raw_body { $_[0]->content }
+
+# XXX you can mutate headers with ->headers but it's not written through to the env
+
+sub headers {
+ my $self = shift;
+ if (!defined $self->{headers}) {
+ my $env = $self->env;
+ $self->{headers} = HTTP::Headers->new(
+ map {
+ (my $field = $_) =~ s/^HTTPS?_//;
+ ( $field => $env->{$_} );
+ }
+ grep { /^(?:HTTP|CONTENT|COOKIE)/i } keys %$env
+ );
+ }
+ $self->{headers};
+}
+# shortcut
+sub content_encoding { shift->headers->content_encoding(@_) }
+sub content_length { shift->headers->content_length(@_) }
+sub content_type { shift->headers->content_type(@_) }
+sub header { shift->headers->header(@_) }
+sub referer { shift->headers->referer(@_) }
+sub user_agent { shift->headers->user_agent(@_) }
+
+sub body_parameters {
+ my $self = shift;
+
+ unless ($self->env->{'plack.request.body'}) {
+ $self->_parse_request_body;
+ }
+
+ return $self->env->{'plack.request.body'};
+}
+
+# contains body + query
+sub parameters {
+ my $self = shift;
+
+ $self->env->{'plack.request.merged'} ||= do {
+ my $query = $self->query_parameters;
+ my $body = $self->body_parameters;
+ Hash::MultiValue->new($query->flatten, $body->flatten);
+ };
+}
+
+sub uploads {
+ my $self = shift;
+
+ if ($self->env->{'plack.request.upload'}) {
+ return $self->env->{'plack.request.upload'};
+ }
+
+ $self->_parse_request_body;
+ return $self->env->{'plack.request.upload'};
+}
+
+sub hostname { _deprecated 'remote_host'; $_[0]->remote_host || $_[0]->address }
+sub url_scheme { _deprecated 'scheme'; $_[0]->scheme }
+sub params { _deprecated 'parameters'; shift->parameters(@_) }
+sub query_params { _deprecated 'query_parameters'; shift->query_parameters(@_) }
+sub body_params { _deprecated 'body_parameters'; shift->body_parameters(@_) }
+
+sub cookie {
+ my $self = shift;
+ _deprecated 'cookies';
+
+ return keys %{ $self->cookies } if @_ == 0;
+
+ my $name = shift;
+ return $self->cookies->{$name};
+}
+
+sub param {
+ my $self = shift;
+
+ return keys %{ $self->parameters } if @_ == 0;
+
+ my $key = shift;
+ return $self->parameters->{$key} unless wantarray;
+ return $self->parameters->get_all($key);
+}
+
+sub upload {
+ my $self = shift;
+
+ return keys %{ $self->uploads } if @_ == 0;
+
+ my $key = shift;
+ return $self->uploads->{$key} unless wantarray;
+ return $self->uploads->get_all($key);
+}
+
+sub raw_uri {
+ my $self = shift;
+ _deprecated 'base';
+
+ my $base = $self->base;
+ $base->path_query($self->env->{REQUEST_URI});
+
+ $base;
+}
+
+sub uri {
+ my $self = shift;
+
+ my $base = $self->_uri_base;
+
+ my $path = $self->env->{PATH_INFO} || '';
+ $path .= '?' . $self->env->{QUERY_STRING}
+ if defined $self->env->{QUERY_STRING} && $self->env->{QUERY_STRING} ne '';
+
+ $base =~ s!/$!! if $path =~ m!^/!;
+
+ return URI->new($base . $path)->canonical;
+}
+
+sub base {
+ my $self = shift;
+ URI->new($self->_uri_base)->canonical;
+}
+
+sub _uri_base {
+ my $self = shift;
+
+ my $env = $self->env;
+
+ my $uri = ($env->{'psgi.url_scheme'} || "http") .
+ "://" .
+ ($env->{HTTP_HOST} || (($env->{SERVER_NAME} || "") . ":" . ($env->{SERVER_PORT} || 80))) .
+ ($env->{SCRIPT_NAME} || '/');
+
+ return $uri;
+}
+
+sub new_response {
+ my $self = shift;
+ require Plack::Response;
+ Plack::Response->new(@_);
+}
+
+sub _parse_request_body {
+ my $self = shift;
+
+ my $ct = $self->env->{CONTENT_TYPE};
+ my $cl = $self->env->{CONTENT_LENGTH};
+ if (!$ct && !$cl) {
+ # No Content-Type nor Content-Length -> GET/HEAD
+ $self->env->{'plack.request.body'} = Hash::MultiValue->new;
+ $self->env->{'plack.request.upload'} = Hash::MultiValue->new;
+ return;
+ }
+
+ # Do not use ->content_type to get multipart boundary correctly
+ my $body = HTTP::Body->new($ct, $cl);
+
+ my $input = $self->input;
+
+ my $buffer;
+ if ($self->env->{'psgix.input.buffered'}) {
+ # Just in case if input is read by middleware/apps beforehand
+ $input->seek(0, 0);
+ } else {
+ $buffer = Plack::TempBuffer->new($cl);
+ }
+
+ my $spin = 0;
+ while ($cl) {
+ $input->read(my $chunk, $cl < 8192 ? $cl : 8192);
+ my $read = length $chunk;
+ $cl -= $read;
+ $body->add($chunk);
+ $buffer->print($chunk) if $buffer;
+
+ if ($read == 0 && $spin++ > 2000) {
+ Carp::croak "Bad Content-Length: maybe client disconnect? ($cl bytes remaining)";
+ }
+ }
+
+ if ($buffer) {
+ $self->env->{'psgix.input.buffered'} = 1;
+ $self->env->{'psgi.input'} = $buffer->rewind;
+ } else {
+ $input->seek(0, 0);
+ }
+
+ $self->env->{'plack.request.body'} = Hash::MultiValue->from_mixed($body->param);
+
+ my @uploads = Hash::MultiValue->from_mixed($body->upload)->flatten;
+ my @obj;
+ while (my($k, $v) = splice @uploads, 0, 2) {
+ push @obj, $k, $self->_make_upload($v);
+ }
+
+ $self->env->{'plack.request.upload'} = Hash::MultiValue->new(@obj);
+
+ 1;
+}
+
+sub _make_upload {
+ my($self, $upload) = @_;
+ Plack::Request::Upload->new(
+ headers => HTTP::Headers->new( %{delete $upload->{headers}} ),
+ %$upload,
+ );
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Request - Portable HTTP request object from PSGI env hash
+
+=head1 SYNOPSIS
+
+ use Plack::Request;
+
+ my $app_or_middleware = sub {
+ my $env = shift; # PSGI env
+
+ my $req = Plack::Request->new($env);
+
+ my $path_info = $req->path_info;
+ my $query = $req->param('query');
+
+ my $res = $req->new_response(200); # new Plack::Response
+ $res->finalize;
+ };
+
+=head1 DESCRIPTION
+
+L<Plack::Request> provides a consistent API for request objects across
+web server environments.
+
+=head1 CAVEAT
+
+Note that this module is intended to be used by Plack middleware
+developers and web application framework developers rather than
+application developers (end users).
+
+Writing your web application directly using Plack::Request is
+certainly possible but not recommended: it's like doing so with
+mod_perl's Apache::Request: yet too low level.
+
+If you're writing a web application, not a framework, then you're
+encouraged to use one of the web application frameworks that support
+PSGI, or see L<Piglet> or L<HTTP::Engine> to provide higher level
+Request and Response API on top of PSGI.
+
+=head1 METHODS
+
+Some of the methods defined in the earlier versions are deprecated in
+version 1.00. Take a look at L</"INCOMPATIBILITIES">.
+
+Unless otherwise noted, all methods and attributes are B<read-only>,
+and passing values to the method like an accessor doesn't work like
+you expect it to.
+
+=head2 new
+
+ Plack::Request->new( $env );
+
+Creates a new request object.
+
+=head1 ATTRIBUTES
+
+=over 4
+
+=item env
+
+Returns the shared PSGI environment hash reference. This is a
+reference, so writing to this environment passes through during the
+whole PSGI request/response cycle.
+
+=item address
+
+Returns the IP address of the client (C<REMOTE_ADDR>).
+
+=item remote_host
+
+Returns the remote host (C<REMOTE_HOST>) of the client. It may be
+empty, in which case you have to get the IP address using C<address>
+method and resolve by your own.
+
+=item method
+
+Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
+
+=item protocol
+
+Returns the protocol (HTTP/1.0 or HTTP/1.1) used for the current request.
+
+=item request_uri
+
+Returns the raw, undecoded request URI path. You probably do B<NOT>
+want to use this to dispatch requests.
+
+=item path_info
+
+Returns B<PATH_INFO> in the environment. Use this to get the local
+path for the requests.
+
+=item path
+
+Similar to C<path_info> but returns C</> in case it is empty. In other
+words, it returns the virtual path of the request URI after C<<
+$req->base >>. See L</"DISPATCHING"> for details.
+
+=item script_name
+
+Returns B<SCRIPT_NAME> in the environment. This is the absolute path
+where your application is hosted.
+
+=item scheme
+
+Returns the scheme (C<http> or C<https>) of the request.
+
+=item secure
+
+Returns true or false, indicating whether the connection is secure (https).
+
+=item body, input
+
+Returns C<psgi.input> handle.
+
+=item session
+
+Returns (optional) C<psgix.session> hash. When it exists, you can
+retrieve and store per-session data from and to this hash.
+
+=item session_options
+
+Returns (optional) C<psgix.session.options> hash.
+
+=item logger
+
+Returns (optional) C<psgix.logger> code reference. When it exists,
+your application is supposed to send the log message to this logger,
+using:
+
+ $req->logger->({ level => 'debug', message => "This is a debug message" });
+
+=item cookies
+
+Returns a reference to a hash containing the cookies. Values are
+strings that are sent by clients and are URI decoded.
+
+=item query_parameters
+
+Returns a reference to a hash containing query string (GET)
+parameters. This hash reference is L<Hash::MultiValue> object.
+
+=item body_parameters
+
+Returns a reference to a hash containing posted parameters in the
+request body (POST). Similarly to C<query_parameters>, the hash
+reference is a L<Hash::MultiValue> object.
+
+=item parameters
+
+Returns a L<Hash::MultiValue> hash reference containing (merged) GET
+and POST parameters.
+
+=item content, raw_body
+
+Returns the request content in an undecoded byte string for POST requests.
+
+=item uri
+
+Returns an URI object for the current request. The URI is constructed
+using various environment values such as C<SCRIPT_NAME>, C<PATH_INFO>,
+C<QUERY_STRING>, C<HTTP_HOST>, C<SERVER_NAME> and C<SERVER_PORT>.
+
+Every time this method is called it returns a new, cloned URI object.
+
+=item base
+
+Returns an URI object for the base path of current request. This is
+like C<uri> but only contains up to C<SCRIPT_NAME> where your
+application is hosted at.
+
+Every time this method is called it returns a new, cloned URI object.
+
+=item user
+
+Returns C<REMOTE_USER> if it's set.
+
+=item headers
+
+Returns an L<HTTP::Headers> object containing the headers for the current request.
+
+=item uploads
+
+Returns a reference to a hash containing uploads. The hash reference
+is L<Hash::MultiValue> object and values are L<Plack::Request::Upload>
+objects.
+
+=item content_encoding
+
+Shortcut to $req->headers->content_encoding.
+
+=item content_length
+
+Shortcut to $req->headers->content_length.
+
+=item content_type
+
+Shortcut to $req->headers->content_type.
+
+=item header
+
+Shortcut to $req->headers->header.
+
+=item referer
+
+Shortcut to $req->headers->referer.
+
+=item user_agent
+
+Shortcut to $req->headers->user_agent.
+
+=item param
+
+Returns GET and POST parameters with a CGI.pm-compatible param
+method. This is an alternative method for accessing parameters in
+$req->parameters.
+
+ $value = $req->param( 'foo' );
+ @values = $req->param( 'foo' );
+ @params = $req->param;
+
+=item upload
+
+A convenient method to access $req->uploads.
+
+ $upload = $req->upload('field');
+ @uploads = $req->upload('field');
+ @fields = $req->upload;
+
+ for my $upload ( $req->upload('field') ) {
+ print $upload->filename;
+ }
+
+=item new_response
+
+ my $res = $req->new_response;
+
+Creates a new L<Plack::Response> object. Handy to remove dependency on
+L<Plack::Response> in your code for easy subclassing and duck typing
+in web application frameworks, as well as overriding Response
+generation in middlewares.
+
+=back
+
+=head2 Hash::MultiValue parameters
+
+Parameters that can take one or multiple values i.e. C<parameters>,
+C<query_parameters>, C<body_parameters> and C<uploads> store those
+hash reference as a L<Hash::MultiValue> object. This means you can use
+the hash reference as a plain hash where values are B<always> scalars
+(B<NOT> array reference), so you don't need to code ugly and unsafe
+C<< ref ... eq 'ARRAY' >> anymore.
+
+And if you explicitly want to get multiple values of the same key, you
+can call the method on it, such as:
+
+ my @foo = $req->query_parameters->get_all('foo');
+
+You can also call C<get_one> to always get one parameter independent
+of the context (unlike C<param>), and eve call C<mixed> (with
+Hash::MultiValue 0.05 or later) to get the I<traditional> hash
+reference,
+
+ my $params = $req->prameters->mixed;
+
+where values are either a scalar or an array reference depending on
+input, so it might be useful if you already have the code to deal with
+that ugliness.
+
+=head2 PARSING POST BODY and MULTIPLE OBJECTS
+
+The methods to parse request body (C<content>, C<body_parameters> and
+C<uploads>) are carefully coded to save the parsed body in the
+environment hash as well as in the temporary buffer, so you can call
+them multiple times and create Plack::Request objects multiple times
+in a request and they should work safely, and won't parse request body
+more than twice for the efficiency.
+
+=head1 DISPATCHING
+
+If your application or framework wants to dispatch (or route) actions
+based on request paths, be sure to use C<< $req->path_info >> not C<<
+$req->uri->path >>.
+
+It is because C<path_info> gives you the virtual path of the request,
+regardless of how your application is mounted. If your application is
+hosted with mod_perl or CGI scripts, or even multiplexed with tools
+like L<Plack::App::URLMap>, request's C<path_info> always gives you
+the action path.
+
+Note that C<path_info> might give you an empty string, in which case
+you should assume just like C</>.
+
+You will also like to use C<< $req->base >> as a base prefix when
+building URLs in your templates or in redirections. It's a good idea
+for you to subclass Plack::Request and define methods such as:
+
+ sub uri_for {
+ my($self, $path, $args) = @_;
+ my $uri = $self->base;
+ $uri->path($uri->path . $path);
+ $uri->query_form(@$args) if $args;
+ $uri;
+ }
+
+So you can say:
+
+ my $link = $req->uri_for('/logout', [ signoff => 1 ]);
+
+and if C<< $req->base >> is C</app> you'll get the full URI for
+C</app/logout?signoff=1>.
+
+=head1 INCOMPATIBILITIES
+
+In version 1.0, many utility methods are removed or deprecated, and
+most methods are made read-only.
+
+The following methods are deprecated: C<hostname>, C<url_scheme>,
+C<params>, C<query_params>, C<body_params>, C<cookie> and
+C<raw_uri>. They will be removed in the next major release.
+
+All parameter-related methods such as C<parameters>,
+C<body_parameters>, C<query_parameters> and C<uploads> now contains
+L<Hash::MultiValue> objects, rather than I<scalar or an array
+reference depending on the user input> which is insecure. See
+L<Hash::MultiValue> for more about this change.
+
+C<< $req->path >> method had a bug, where the code and the document
+was mismatching. The document was suggesting it returns the sub
+request path after C<< $req->base >> but the code was always returning
+the absolute URI path. The code is now updated to be an alias of C<<
+$req->path_info >> but returns C</> in case it's empty. If you need
+the older behavior, just call C<< $req->uri->path >> instead.
+
+Cookie handling is simplified, and doesn't use L<CGI::Simple::Cookie>
+anymore, which means you B<CAN NOT> set array reference or hash
+reference as a cookie value and expect it be serialized. You're always
+required to set string value, and encoding or decoding them is totally
+up to your application or framework. Also, C<cookies> hash reference
+now returns I<strings> for the cookies rather than CGI::Simple::Cookie
+objects, which means you no longer have to write a wacky code such as:
+
+ $v = $req->cookie->{foo} ? $req->cookie->{foo}->value : undef;
+
+and instead, simply do:
+
+ $v = $req->cookie->{foo};
+
+=head1 AUTHORS
+
+Tatsuhiko Miyagawa
+
+Kazuhiro Osawa
+
+Tokuhiro Matsuno
+
+=head1 SEE ALSO
+
+L<Plack::Response> L<HTTP::Request>, L<Catalyst::Request>
+
+=head1 LICENSE
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
@@ -0,0 +1,282 @@
+package Plack::Response;
+use strict;
+use warnings;
+our $VERSION = '0.9911';
+$VERSION = eval $VERSION;
+
+use Plack::Util::Accessor qw(body status);
+use Carp ();
+use Scalar::Util ();
+use HTTP::Headers;
+use URI::Escape ();
+
+sub code { shift->status(@_) }
+sub content { shift->body(@_) }
+
+sub new {
+ my($class, $rc, $headers, $content) = @_;
+
+ my $self = bless {}, $class;
+ $self->status($rc) if defined $rc;
+ $self->headers($headers) if defined $headers;
+ $self->body($content) if defined $content;
+
+ $self;
+}
+
+sub headers {
+ my $self = shift;
+
+ if (@_) {
+ my $headers = shift;
+ if (ref $headers eq 'ARRAY') {
+ Carp::carp("Odd number of headers") if @$headers % 2 != 0;
+ $headers = HTTP::Headers->new(@$headers);
+ } elsif (ref $headers eq 'HASH') {
+ $headers = HTTP::Headers->new(%$headers);
+ }
+ return $self->{headers} = $headers;
+ } else {
+ return $self->{headers} ||= HTTP::Headers->new();
+ }
+}
+
+sub cookies {
+ my $self = shift;
+ if (@_) {
+ $self->{cookies} = shift;
+ } else {
+ return $self->{cookies} ||= +{ };
+ }
+}
+
+sub header { shift->headers->header(@_) } # shortcut
+
+sub content_length {
+ shift->headers->content_length(@_);
+}
+
+sub content_type {
+ shift->headers->content_type(@_);
+}
+
+sub content_encoding {
+ shift->headers->content_encoding(@_);
+}
+
+sub location {
+ shift->headers->header('Location' => @_);
+}
+
+sub redirect {
+ my $self = shift;
+
+ if (@_) {
+ my $url = shift;
+ my $status = shift || 302;
+ $self->location($url);
+ $self->status($status);
+ }
+
+ return $self->location;
+}
+
+sub finalize {
+ my $self = shift;
+ Carp::croak "missing status" unless $self->status();
+
+ $self->_finalize_cookies();
+
+ return [
+ $self->status,
+ +[
+ map {
+ my $k = $_;
+ map { ( $k => $_ ) } $self->headers->header($_);
+ } $self->headers->header_field_names
+ ],
+ $self->_body,
+ ];
+}
+
+sub _body {
+ my $self = shift;
+ my $body = $self->body;
+ $body = [] unless defined $body;
+ if (!ref $body or Scalar::Util::blessed($body) && overload::Method($body, q(""))) {
+ return [ $body ];
+ } else {
+ return $body;
+ }
+}
+
+sub _finalize_cookies {
+ my $self = shift;
+
+ while (my($name, $val) = each %{$self->cookies}) {
+ my $cookie = $self->_bake_cookie($name, $val);
+ $self->headers->push_header( 'Set-Cookie' => $cookie );
+ }
+}
+
+sub _bake_cookie {
+ my($self, $name, $val) = @_;
+
+ return '' unless defined $val;
+ $val = { value => $val } unless ref $val eq 'HASH';
+
+ my @cookie = ( URI::Escape::uri_escape($name) . "=" . URI::Escape::uri_escape($val->{value}) );
+ push @cookie, "domain=" . $val->{domain} if $val->{domain};
+ push @cookie, "path=" . $val->{path} if $val->{path};
+ push @cookie, "expires=" . $self->_date($val->{expires}) if $val->{expires};
+ push @cookie, "secure" if $val->{secure};
+ push @cookie, "HttpOnly" if $val->{httponly};
+
+ return join "; ", @cookie;
+}
+
+my @MON = qw( Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec );
+my @WDAY = qw( Sun Mon Tue Wed Thu Fri Sat );
+
+sub _date {
+ my($self, $expires) = @_;
+
+ if ($expires =~ /^\d+$/) {
+ # all numbers -> epoch date
+ # (cookies use '-' as date separator, HTTP uses ' ')
+ my($sec, $min, $hour, $mday, $mon, $year, $wday) = gmtime($expires);
+ $year += 1900;
+
+ return sprintf("%s, %02d-%s-%04d %02d:%02d:%02d GMT",
+ $WDAY[$wday], $mday, $MON[$mon], $year, $hour, $min, $sec);
+
+ }
+
+ return $expires;
+}
+
+1;
+__END__
+
+=head1 NAME
+
+Plack::Response - Portable HTTP Response object for PSGI response
+
+=head1 SYNOPSIS
+
+ use Plack::Response;
+
+ sub psgi_handler {
+ my $env = shift;
+
+ my $res = Plack::Response->new(200);
+ $res->content_type('text/html');
+ $res->body("Hello World");
+
+ return $res->finalize;
+ }
+
+=head1 DESCRIPTION
+
+Plack::Response allows you a way to create PSGI response array ref through a simple API.
+
+=head1 METHODS
+
+=over 4
+
+=item new
+
+ $res = Plack::Response->new;
+ $res = Plack::Response->new($status);
+ $res = Plack::Response->new($status, $headers);
+ $res = Plack::Response->new($status, $headers, $body);
+
+Creates a new Plack::Response object.
+
+=item status
+
+ $res->status(200);
+ $status = $res->status;
+
+Sets and gets HTTP status code. C<code> is an alias.
+
+=item headers
+
+ $headers = $res->headers;
+ $res->headers([ 'Content-Type' => 'text/html' ]);
+ $res->headers({ 'Content-Type' => 'text/html' });
+ $res->headers( HTTP::Headers->new );
+
+Sets and gets HTTP headers of the response. Setter can take either an
+array ref, a hash ref or L<HTTP::Headers> object containing a list of
+headers.
+
+=item body
+
+ $res->body($body_str);
+ $res->body([ "Hello", "World" ]);
+ $res->body($io);
+
+Gets and sets HTTP response body. Setter can take either a string, an
+array ref, or an IO::Handle-like object. C<content> is an alias.
+
+=item header
+
+ $res->header('X-Foo' => 'bar');
+ my $val = $res->header('X-Foo');
+
+Shortcut for C<< $res->headers->header >>.
+
+=item content_type, content_length, content_encoding
+
+ $res->content_type('text/plain');
+ $res->content_length(123);
+ $res->content_encoding('gzip');
+
+Shortcut for the equivalent get/set methods in C<< $res->headers >>.
+
+=item redirect
+
+ $res->redirect($url);
+ $res->redirect($url, 301);
+
+Sets redirect URL with an optional status code, which defaults to 302.
+
+=item location
+
+Gets and sets C<Location> header.
+
+=item cookies
+
+ $res->cookies->{foo} = 123;
+ $res->cookies->{foo} = { value => '123' };
+
+Returns a hash reference containing cookies to be set in the
+response. The keys of the hash are the cookies' names, and their
+corresponding values are a plain string (for C<value> with everything
+else defaults) or a hash reference that can contain keys such as
+C<value>, C<domain>, C<expires>, C<path>, C<httponly>, C<secure>.
+
+C<expires> can take a string or an integer (as an epoch time) and
+B<does not> convert string formats such as C<+3M>.
+
+ $res->cookies->{foo} = {
+ value => 'test',
+ path => "/",
+ domain => '.example.com',
+ expires => time + 24 * 60 * 60,
+ };
+
+=back
+
+=head1 AUTHOR
+
+Tokuhiro Matsuno
+
+Tatsuhiko Miyagawa
+
+=head1 SEE ALSO
+
+L<Plack::Request>
+
+=cut
@@ -1,15 +1,19 @@
package Plack::Runner;
use strict;
use warnings;
-use File::Basename;
-use Getopt::Long;
-use Plack::Loader;
+use Carp ();
use Plack::Util;
use Try::Tiny;
sub new {
my $class = shift;
- bless {}, $class;
+ bless {
+ env => $ENV{PLACK_ENV},
+ loader => 'Plack::Loader',
+ includes => [],
+ modules => [],
+ @_,
+ }, $class;
}
# delay the build process for reloader
@@ -19,63 +23,39 @@ sub build(&;$) {
return sub { $block->($app->()) };
}
-sub run {
+sub parse_options {
my $self = shift;
- $self = $self->new unless ref $self;
local @ARGV = @_;
- my $psgi;
- my $eval;
- my $host;
- my $port = 5000;
- my $env = "development";
- my $help = 0;
- my $backend;
- my @reload;
- my $reload;
- my @includes;
- my @modules;
-
# From 'prove': Allow cuddling the paths with -I and -M
@ARGV = map { /^(-[IM])(.+)/ ? ($1,$2) : $_ } @ARGV;
+ my($host, $port, $socket, @listen);
+
+ require Getopt::Long;
Getopt::Long::Configure("no_ignore_case", "pass_through");
- GetOptions(
- "a|app=s" => \$psgi,
+ Getopt::Long::GetOptions(
+ "a|app=s" => \$self->{app},
"o|host=s" => \$host,
"p|port=i" => \$port,
- "s|server=s" => \$backend,
- "i|impl=s" => sub { warn "-i is deprecated. Use -s instead\n"; $backend = $_[1] },
- "E|env=s" => \$env,
- "e=s" => \$eval,
- 'I=s@' => \@includes,
- 'M=s@' => \@modules,
- 'r|reload' => sub { $reload = 1 },
- 'R|Reload=s' => sub { push @reload, split ",", $_[1] },
- "h|help", => \$help,
+ "s|server=s" => \$self->{server},
+ "S|socket=s" => \$socket,
+ 'l|listen=s@' => \@listen,
+ 'D|daemonize' => \$self->{daemonize},
+ "E|env=s" => \$self->{env},
+ "e=s" => \$self->{eval},
+ 'I=s@' => $self->{includes},
+ 'M=s@' => $self->{modules},
+ 'r|reload' => sub { $self->{loader} = "Restarter" },
+ 'R|Reload=s' => sub { $self->{loader} = "Restarter"; $self->loader->watch(split ",", $_[1]) },
+ 'L|loader=s' => \$self->{loader},
+ "h|help", => \$self->{help},
);
- if ($help) {
- require Pod::Usage;
- Pod::Usage::pod2usage(0);
- }
-
- lib->import(@includes) if @includes;
-
- if ($eval) {
- push @modules, 'Plack::Builder';
- }
-
- for (@modules) {
- my($module, @import) = split /[=,]/;
- eval "require $module" or die $@;
- $module->import(@import);
- }
-
my(@options, @argv);
while (defined($_ = shift @ARGV)) {
- if (s/^--//) {
+ if (s/^--?//) {
my @v = split '=', $_, 2;
$v[0] =~ tr/-/_/;
if (@v == 2) {
@@ -88,36 +68,158 @@ sub run {
}
}
- push @options, host => $host, port => $port;
+ push @options, $self->mangle_host_port_socket($host, $port, $socket, @listen);
+ push @options, daemonize => 1 if $self->{daemonize};
+
+ $self->{options} = \@options;
+ $self->{argv} = \@argv;
+}
+
+sub set_options {
+ my $self = shift;
+ push @{$self->{options}}, @_;
+}
- $psgi ||= $argv[0] || "app.psgi";
- my $app = $eval ? build { no strict; no warnings; eval $eval or die $@ }
- : ref $psgi eq 'CODE' ? sub { $psgi }
- : build { Plack::Util::load_psgi $psgi };
+sub mangle_host_port_socket {
+ my($self, $host, $port, $socket, @listen) = @_;
+
+ for my $listen (reverse @listen) {
+ if ($listen =~ /:\d+$/) {
+ ($host, $port) = split /:/, $listen, 2;
+ $host = undef if $host eq '';
+ } else {
+ $socket ||= $listen;
+ }
+ }
+
+ unless (@listen) {
+ if ($socket) {
+ @listen = ($socket);
+ } else {
+ $port ||= 5000;
+ @listen = ($host ? "$host:$port" : ":$port");
+ }
+ }
+
+ return host => $host, port => $port, listen => \@listen, socket => $socket;
+}
+
+sub setup {
+ my $self = shift;
+
+ if ($self->{help}) {
+ require Pod::Usage;
+ Pod::Usage::pod2usage(0);
+ }
+
+ lib->import(@{$self->{includes}}) if @{$self->{includes}};
+
+ if ($self->{eval}) {
+ push @{$self->{modules}}, 'Plack::Builder';
+ }
- if ($env eq 'development') {
- require Plack::Middleware::StackTrace;
- require Plack::Middleware::AccessLog;
- $app = build { Plack::Middleware::StackTrace->wrap($_[0]) } $app;
+ for (@{$self->{modules}}) {
+ my($module, @import) = split /[=,]/;
+ eval "require $module" or die $@;
+ $module->import(@import);
+ }
+}
+
+sub locate_app {
+ my($self, @args) = @_;
+
+ my $psgi = $self->{app} || $args[0];
+
+ if (ref $psgi eq 'CODE') {
+ return sub { $psgi };
+ }
+
+ if ($self->{eval}) {
+ $self->loader->watch("lib");
+ return build {
+ no strict;
+ no warnings;
+ my $eval = "builder { $self->{eval};";
+ $eval .= "Plack::Util::load_psgi(\$psgi);" if $psgi;
+ $eval .= "}";
+ eval $eval or die $@;
+ };
+ }
+
+ $psgi ||= "app.psgi";
+
+ require File::Basename;
+ $self->loader->watch( File::Basename::dirname($psgi) . "/lib", $psgi );
+ build { Plack::Util::load_psgi $psgi };
+}
+
+sub watch {
+ my($self, @dir) = @_;
+
+ push @{$self->{watch}}, @dir
+ if $self->{loader} eq 'Restarter';
+}
+
+sub prepare_devel {
+ my($self, $app) = @_;
+
+ require Plack::Middleware::StackTrace;
+ require Plack::Middleware::AccessLog;
+ $app = build { Plack::Middleware::StackTrace->wrap($_[0]) } $app;
+ unless ($ENV{GATEWAY_INTERFACE}) {
$app = build { Plack::Middleware::AccessLog->wrap($_[0], logger => sub { print STDERR @_ }) } $app;
}
- my $loader;
+ push @{$self->{options}}, server_ready => sub {
+ my($args) = @_;
+ my $name = $args->{server_software} || ref($args); # $args is $server
+ my $host = $args->{host} || 0;
+ print STDERR "$name: Accepting connections at http://$host:$args->{port}/\n";
+ };
- if ($reload or @reload) {
- if ($reload) {
- push @reload, $eval ? "lib" : ( File::Basename::dirname($psgi) . "/lib", $psgi );
- }
- warn "plackup: Watching ", join(", ", @reload), " for changes\n";
- require Plack::Loader::Reloadable;
- $loader = Plack::Loader::Reloadable->new(\@reload);
+ $app;
+}
+
+sub loader {
+ my $self = shift;
+ $self->{_loader} ||= Plack::Util::load_class($self->{loader}, 'Plack::Loader')->new;
+}
+
+sub load_server {
+ my($self, $loader) = @_;
+
+ if ($self->{server}) {
+ return $loader->load($self->{server}, @{$self->{options}});
} else {
- $loader = 'Plack::Loader';
- $app = $app->();
+ return $loader->auto(@{$self->{options}});
}
+}
+
+sub run {
+ my $self = shift;
+
+ unless (ref $self) {
+ $self = $self->new;
+ $self->parse_options(@_);
+ return $self->run;
+ }
+
+ my @args = @_ ? @_ : @{$self->{argv}};
+
+ $self->setup;
+
+ my $app = $self->locate_app(@args);
+
+ $ENV{PLACK_ENV} ||= $self->{env} || 'development';
+ if ($ENV{PLACK_ENV} eq 'development') {
+ $app = $self->prepare_devel($app);
+ }
+
+ my $loader = $self->loader;
+ $loader->preload_app($app);
- my $server = $backend ? $loader->load($backend, @options) : $loader->auto(@options);
- $server->run($app);
+ my $server = $self->load_server($loader);
+ $loader->run($server);
}
1;
@@ -134,7 +236,9 @@ Plack::Runner - plackup core
use Plack::Runner;
my $app = sub { ... };
- Plack::Runner->run('--app' => $app, @ARGV);
+ my $runner = Plack::Runner->new;
+ $runner->parse_options(@ARGV);
+ $runner->run($app);
=head1 DESCRIPTION
@@ -154,8 +258,8 @@ automatically extracted from your own script using L<Pod::Usage>.
=head1 NOTES
Do not directly call this module from your C<.psgi>, since that makes
-your PSGI application unnecesarily depend on L<plackup> and won't run
-other backends like L<Plack::Server::Apache2> or mod_psgi.
+your PSGI application unnecessarily depend on L<plackup> and won't run
+other backends like L<Plack::Handler::Apache2> or mod_psgi.
If you I<really> want to make your C<.psgi> runnable as a standalone
script, you can do this:
@@ -1,135 +1,24 @@
package Plack::Server::Apache1;
use strict;
-use Apache::Request;
-use Apache::Constants qw(:common :response);
+use parent qw(Plack::Handler::Apache1);
+use Carp;
-use Plack::Util;
-use Scalar::Util;
-
-my %apps; # psgi file to $app mapping
-
-sub preload {
+sub new {
my $class = shift;
- for my $app (@_) {
- $class->load_app($app);
- }
-}
-
-sub load_app {
- my($class, $app) = @_;
- return $apps{$app} ||= do {
- local $ENV{MOD_PERL}; # trick Catalyst/CGI.pm etc.
- Plack::Util::load_psgi $app;
- };
-}
-
-sub handler {
- my $r = shift;
- my $apr = Apache::Request->new($r);
-
- my $psgi = $r->dir_config('psgi_app');
- my $app = __PACKAGE__->load_app($psgi);
-
- $r->subprocess_env; # let Apache create %ENV for us :)
-
- my $env = {
- %ENV,
- 'psgi.version' => [ 1, 0 ],
- 'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
- 'psgi.input' => $r,
- 'psgi.errors' => *STDERR,
- 'psgi.multithread' => Plack::Util::FALSE,
- 'psgi.multiprocess' => Plack::Util::TRUE,
- 'psgi.run_once' => Plack::Util::FALSE,
- 'psgi.streaming' => Plack::Util::TRUE,
- };
-
- my $vpath = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
-
- my $location = $r->location || "/";
- $location =~ s{/$}{};
- (my $path_info = $vpath) =~ s/^\Q$location\E//;
-
- $env->{SCRIPT_NAME} = $location;
- $env->{PATH_INFO} = $path_info;
-
- my $res = $app->($env);
-
- if (ref $res eq 'ARRAY') {
- _handle_response($r, $res);
- }
- elsif (ref $res eq 'CODE') {
- $res->(sub {
- _handle_response($r, $_[0]);
- });
- }
- else {
- die "Bad response $res";
- }
-
- return OK;
-}
-
-sub _handle_response {
- my ($r, $res) = @_;
- my ($status, $headers, $body) = @{ $res };
-
- my $hdrs = ($status >= 200 && $status < 300)
- ? $r->headers_out : $r->err_headers_out;
-
- Plack::Util::header_iter($headers, sub {
- my($h, $v) = @_;
- if (lc $h eq 'content-type') {
- $r->content_type($v);
- } else {
- $hdrs->add($h => $v);
- }
- });
-
- $r->status($status);
- $r->send_http_header;
-
- if (defined $body) {
- if (Plack::Util::is_real_fh($body)) {
- $r->send_fd($body);
- } else {
- Plack::Util::foreach($body, sub { $r->print(@_) });
- }
- }
- else {
- return Plack::Util::inline_object
- write => sub { $r->print(@_) },
- close => sub { };
- }
+ Carp::carp "Use of $class is deprecated. Use Plack::Handler::Apache1 or Plack::Loader to upgrade.";
+ $class->SUPER::new(@_);
}
1;
__END__
-
=head1 NAME
-Plack::Server::Apache1 - Apache 1.3.x handlers to run PSGI application
-
-=head1 SYNOPSIS
-
- <Locaion />
- SetHandler perl-script
- PerlHandler Plack::Server::Apache1
- PerlSetVar psgi_app /path/to/app.psgi
- </Location>
+Plack::Server::Apache1 - DEPRECATED
- <Perl>
- use Plack::Server::Apache1;
- Plack::Server::Apache1->preload("/path/to/app.psgi");
- </Perl>
+=head1 DESCRIPTION
-=head1 AUTHOR
-
-Aaron Trevena
-
-Tatsuhiko Miyagawa
+B<This module is deprecated>. See L<Plack::Handler::Apache1>.
=cut
-
@@ -1,112 +1,12 @@
package Plack::Server::Apache2;
use strict;
-use warnings;
-use Apache2::RequestRec;
-use Apache2::RequestIO;
-use Apache2::RequestUtil;
-use Apache2::Response;
-use Apache2::Const -compile => qw(OK);
-use APR::Table;
-use IO::Handle;
-use Plack::Util;
-use Scalar::Util;
+use parent qw(Plack::Handler::Apache2);
+use Carp;
-my %apps; # psgi file to $app mapping
-
-sub preload {
+sub new {
my $class = shift;
- for my $app (@_) {
- $class->load_app($app);
- }
-}
-
-sub load_app {
- my($class, $app) = @_;
- return $apps{$app} ||= do {
- local $ENV{MOD_PERL}; # trick Catalyst/CGI.pm etc.
- Plack::Util::load_psgi $app;
- };
-}
-
-sub handler {
- my $r = shift;
-
- my $psgi = $r->dir_config('psgi_app');
- my $app = __PACKAGE__->load_app($psgi);
-
- $r->subprocess_env; # let Apache create %ENV for us :)
-
- my $env = {
- %ENV,
- 'psgi.version' => [ 1, 0 ],
- 'psgi.url_scheme' => ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
- 'psgi.input' => $r,
- 'psgi.errors' => *STDERR,
- 'psgi.multithread' => Plack::Util::FALSE,
- 'psgi.multiprocess' => Plack::Util::TRUE,
- 'psgi.run_once' => Plack::Util::FALSE,
- 'psgi.streaming' => Plack::Util::TRUE,
- };
-
- my $vpath = $env->{SCRIPT_NAME} . $env->{PATH_INFO};
- my $location = $r->location || "/";
- $location =~ s{/$}{};
- (my $path_info = $vpath) =~ s/^\Q$location\E//;
-
- $env->{SCRIPT_NAME} = $location;
- $env->{PATH_INFO} = $path_info;
-
- my $res = $app->($env);
-
- if (ref $res eq 'ARRAY') {
- _handle_response($r, $res);
- }
- elsif (ref $res eq 'CODE') {
- $res->(sub {
- _handle_response($r, $_[0]);
- });
- }
- else {
- die "Bad response $res";
- }
-
- return Apache2::Const::OK;
-}
-
-sub _handle_response {
- my ($r, $res) = @_;
-
- my ($status, $headers, $body) = @{ $res };
-
- my $hdrs = ($status >= 200 && $status < 300)
- ? $r->headers_out : $r->err_headers_out;
-
- Plack::Util::header_iter($headers, sub {
- my($h, $v) = @_;
- if (lc $h eq 'content-type') {
- $r->content_type($v);
- } elsif (lc $h eq 'content-length') {
- $r->set_content_length($v);
- } else {
- $hdrs->add($h => $v);
- }
- });
-
- $r->status($status);
-
- if (Scalar::Util::blessed($body) and $body->can('path') and my $path = $body->path) {
- $r->sendfile($path);
- } elsif (defined $body) {
- Plack::Util::foreach($body, sub { $r->print(@_) });
- $r->rflush;
- }
- else {
- return Plack::Util::inline_object
- write => sub { $r->print(@_); $r->rflush },
- close => sub { $r->rflush };
- }
-
- return Apache2::Const::OK;
+ Carp::carp "Use of $class is deprecated. Use Plack::Handler::Apache2 or Plack::Loader to upgrade.";
+ $class->SUPER::new(@_);
}
1;
@@ -115,23 +15,10 @@ __END__
=head1 NAME
-Plack::Server::Apache2 - Apache 2.0 handlers to run PSGI application
-
-=head1 SYNOPSIS
-
- <Locaion />
- SetHandler perl-script
- PerlResponseHandler Plack::Server::Apache2
- PerlSetVar psgi_app /path/to/app.psgi
- </Location>
-
- <Perl>
- use Plack::Server::Apache2;
- Plack::Server::Apache2->preload("/path/to/app.psgi");
- </Perl>
+Plack::Server::Apache2 - DEPRECATED
-=head1 AUTHOR
+=head1 DESCRIPTION
-Tatsuhiko Miyagawa
+B<This module is deprecated>. See L<Plack::Handler::Apache2>.
=cut
@@ -1,114 +1,23 @@
package Plack::Server::CGI;
use strict;
-use warnings;
-use IO::Handle;
-
-sub new { bless {}, shift }
-
-sub run {
- my ($self, $app) = @_;
- my %env;
- while (my ($k, $v) = each %ENV) {
- next unless $k =~ qr/^(?:REQUEST_METHOD|SCRIPT_NAME|PATH_INFO|QUERY_STRING|SERVER_NAME|SERVER_PORT|SERVER_PROTOCOL|CONTENT_LENGTH|CONTENT_TYPE|REMOTE_ADDR|REQUEST_URI)$|^HTTP_/;
- $env{$k} = $v;
- }
- $env{'HTTP_COOKIE'} ||= $ENV{COOKIE};
- $env{'psgi.version'} = [ 1, 0 ];
- $env{'psgi.url_scheme'} = ($ENV{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http';
- $env{'psgi.input'} = *STDIN;
- $env{'psgi.errors'} = *STDERR;
- $env{'psgi.multithread'} = 1==0;
- $env{'psgi.multiprocess'} = 1==1;
- $env{'psgi.run_once'} = 1==1;
- $env{'psgi.streaming'} = 1==1;
- my $res = $app->(\%env);
- if (ref $res eq 'ARRAY') {
- $self->_handle_response($res);
- }
- elsif (ref $res eq 'CODE') {
- $res->(sub {
- $self->_handle_response($_[0]);
- });
- }
- else {
- die "Bad response $res";
- }
-}
-
-sub _handle_response {
- my ($self, $res) = @_;
-
- *STDOUT->autoflush(1);
-
- my $hdrs;
- $hdrs = "Status: $res->[0]\015\012";
-
- my $headers = $res->[1];
- while (my ($k, $v) = splice(@$headers, 0, 2)) {
- $hdrs .= "$k: $v\015\012";
- }
- $hdrs .= "\015\012";
-
- print STDOUT $hdrs;
-
- my $body = $res->[2];
- my $cb = sub { print STDOUT $_[0] };
-
- # inline Plack::Util::foreach here
- if (ref $body eq 'ARRAY') {
- for my $line (@$body) {
- $cb->($line) if length $line;
- }
- }
- elsif (defined $body) {
- local $/ = \65536 unless ref $/;
- while (defined(my $line = $body->getline)) {
- $cb->($line) if length $line;
- }
- $body->close;
- }
- else {
- return Plack::Server::CGI::Writer->new;
- }
-}
-
-package Plack::Server::CGI::Writer;
+use parent qw(Plack::Handler::CGI);
sub new {
- return bless \do { my $x }, $_[0];
+ my $class = shift;
+ print STDERR "Use of $class is deprecated. Use Plack::Handler::CGI or Plack::Loader to upgrade.\n";
+ $class->SUPER::new(@_);
}
-sub write {
- print $_[1];
-}
-
-sub close { }
-
1;
-__END__
-
-=head1 SYNOPSIS
- ## in your .cgi
- #!/usr/bin/perl
- use Plack::Server::CGI;
+__END__
- # or Plack::Util::load_psgi("/path/to/app.psgi");
- my $app = sub {
- my $env = shift;
- return [
- 200,
- [ 'Content-Type' => 'text/plain', 'Content-Length' => 13 ],
- [ 'Hello, world!' ],
- ];
- };
+=head1 NAME
- Plack::Server::CGI->new->run($app);
+Plack::Server::CGI - DEPRECATED
-=head1 SEE ALSO
+=head1 DESCRIPTION
-L<Plack::Server::Base>
+B<This module is deprecated>. See L<Plack::Handler::CGI>.
=cut
-
-
@@ -1,288 +1,24 @@
package Plack::Server::FCGI;
use strict;
-use warnings;
-use constant RUNNING_IN_HELL => $^O eq 'MSWin32';
-
-use Plack::Util;
-use FCGI;
+use parent qw(Plack::Handler::FCGI);
+use Carp;
sub new {
my $class = shift;
- my $self = bless {@_}, $class;
-
- $self->{leave_umask} ||= 0;
- $self->{keep_stderr} ||= 0;
- $self->{nointr} ||= 0;
- $self->{detach} ||= 0;
- $self->{nproc} ||= 1;
- $self->{pidfile} ||= undef;
- $self->{listen} ||= ":$self->{port}" if $self->{port};
- $self->{manager} = 'FCGI::ProcManager' unless exists $self->{manager};
-
- $self;
-}
-
-sub run {
- my ($self, $app) = @_;
-
- my $sock = 0;
- if ($self->{listen}) {
- my $old_umask = umask;
- unless ($self->{leave_umask}) {
- umask(0);
- }
- $sock = FCGI::OpenSocket( $self->{listen}, 100 )
- or die "failed to open FastCGI socket: $!";
- unless ($self->{leave_umask}) {
- umask($old_umask);
- }
- }
- elsif (!RUNNING_IN_HELL) {
- -S STDIN
- or die "STDIN is not a socket: specify a listen location";
- }
-
- my %env;
- my $request = FCGI::Request(
- \*STDIN, \*STDOUT,
- ($self->{keep_stderr} ? \*STDOUT : \*STDERR), \%env, $sock,
- ($self->{nointr} ? 0 : &FCGI::FAIL_ACCEPT_ON_INTR),
- );
-
- my $proc_manager;
-
- if ($self->{listen}) {
- $self->daemon_fork if $self->{detach};
-
- if ($self->{manager}) {
- Plack::Util::load_class($self->{manager});
- $proc_manager = $self->{manager}->new({
- n_processes => $self->{nproc},
- pid_fname => $self->{pidfile},
- });
-
- # detach *before* the ProcManager inits
- $self->daemon_detach if $self->{detach};
-
- $proc_manager->pm_manage;
- }
- elsif ($self->{detach}) {
- $self->daemon_detach;
- }
- }
-
- while ($request->Accept >= 0) {
- $proc_manager && $proc_manager->pm_pre_dispatch;
-
- my $env = {
- %env,
- 'psgi.version' => [1,0],
- 'psgi.url_scheme' => ($env{HTTPS}||'off') =~ /^(?:on|1)$/i ? 'https' : 'http',
- 'psgi.input' => *STDIN,
- 'psgi.errors' => *STDERR, # FCGI.pm redirects STDERR in Accept() loop, so just print STDERR
- # print to the correct error handle based on keep_stderr
- 'psgi.multithread' => Plack::Util::FALSE,
- 'psgi.multiprocess' => Plack::Util::TRUE,
- 'psgi.run_once' => Plack::Util::FALSE,
- 'psgi.streaming' => Plack::Util::TRUE,
- };
-
- # If we're running under Lighttpd, swap PATH_INFO and SCRIPT_NAME if PATH_INFO is empty
- # http://lists.rawmode.org/pipermail/catalyst/2006-June/008361.html
- # Thanks to Mark Blythe for this fix
- if ($env->{SERVER_SOFTWARE} && $env->{SERVER_SOFTWARE} =~ /lighttpd/) {
- $env->{PATH_INFO} ||= delete $env->{SCRIPT_NAME};
- $env->{SCRIPT_NAME} ||= '';
- $env->{SERVER_NAME} =~ s/:\d+$//; # cut off port number
- }
-
- my $res = Plack::Util::run_app $app, $env;
-
- if (ref $res eq 'ARRAY') {
- $self->_handle_response($res);
- }
- elsif (ref $res eq 'CODE') {
- $res->(sub {
- $self->_handle_response($_[0]);
- });
- }
- else {
- die "Bad response $res";
- }
-
- $proc_manager && $proc_manager->pm_post_dispatch();
- }
-}
-
-sub _handle_response {
- my ($self, $res) = @_;
-
- *STDOUT->autoflush(1);
-
- my $hdrs;
- $hdrs = "Status: $res->[0]\015\012";
-
- my $headers = $res->[1];
- while (my ($k, $v) = splice @$headers, 0, 2) {
- $hdrs .= "$k: $v\015\012";
- }
- $hdrs .= "\015\012";
-
- print STDOUT $hdrs;
-
- my $cb = sub { print STDOUT $_[0] };
- my $body = $res->[2];
- if (defined $body) {
- Plack::Util::foreach($body, $cb);
- }
- else {
- return Plack::Util::inline_object
- write => $cb,
- close => sub { };
- }
-}
-
-sub daemon_fork {
- require POSIX;
- fork && exit;
-}
-
-sub daemon_detach {
- my $self = shift;
- print "FastCGI daemon started (pid $$)\n";
- open STDIN, "+</dev/null" or die $!; ## no critic
- open STDOUT, ">&STDIN" or die $!;
- open STDERR, ">&STDIN" or die $!;
- POSIX::setsid();
+ Carp::carp "Use of $class is deprecated. Use Plack::Handler::FCGI or Plack::Loader to upgrade.";
+ $class->SUPER::new(@_);
}
1;
__END__
-=head1 SYNOPSIS
-
- my $server = Plack::Server::FCGI->new(
- nproc => $num_proc,
- listen => $listen,
- detach => 1,
- );
- $server->run($app);
-
-Starts the FastCGI server. If C<$listen> is set, then it specifies a
-location to listen for FastCGI requests;
-
-=head2 OPTIONS
-
-=over 4
-
-=item listen
-
- listen => '/path/to/socket'
- listen => ':8080'
-
-Listen on a socket path, hostname:port, or :port.
-
-=item port
-
-listen via TCP on port on all interfaces (Same as C<< listen => ":$port" >>)
-
-=item leave-umask
-
-Set to 1 to disable setting umask to 0 for socket open
-
-=item nointr
-
-Do not allow the listener to be interrupted by Ctrl+C
-
-=item nproc
-
-Specify a number of processes for FCGI::ProcManager
-
-=item pidfile
-
-Specify a filename for the pid file
-
-=item manager
-
-Specify a FCGI::ProcManager sub-class
-
-=item detach
-
-Detach from console
-
-=item keep-stderr
-
-Send STDERR to STDOUT instead of the webserver
-
-=back
-
-=head2 WEB SERVER CONFIGURATIONS
-
-=head3 nginx
-
-This is an example nginx configuration to run your FCGI daemon on a
-Unix domain socket and run it at the server's root URL (/).
-
- http {
- server {
- listen 3001;
- location / {
- set $script "";
- set $path_info $uri;
- fastcgi_pass unix:/tmp/fastcgi.sock;
- fastcgi_param SCRIPT_NAME $script;
- fastcgi_param PATH_INFO $path_info;
- fastcgi_param QUERY_STRING $query_string;
- fastcgi_param REQUEST_METHOD $request_method;
- fastcgi_param CONTENT_TYPE $content_type;
- fastcgi_param CONTENT_LENGTH $content_length;
- fastcgi_param REQUEST_URI $request_uri;
- fastcgi_param SEREVR_PROTOCOL $server_protocol;
- fastcgi_param REMOTE_ADDR $remote_addr;
- fastcgi_param REMOTE_PORT $remote_port;
- fastcgi_param SERVER_ADDR $server_addr;
- fastcgi_param SERVER_PORT $server_port;
- fastcgi_param SERVER_NAME $server_name;
- }
- }
- }
-
-If you want to host your application in a non-root path, then you
-should mangle this configuration to set the path to C<SCRIPT_NAME> and
-the rest of the path in C<PATH_INFO>.
-
-See L<http://wiki.nginx.org/NginxFcgiExample> for more details.
-
-=head3 Apache mod_fastcgi
-
-You can use C<FastCgiExternalServer> as normal.
-
- FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/fcgi.sock
-
-See L<http://www.fastcgi.com/mod_fastcgi/docs/mod_fastcgi.html#FastCgiExternalServer> for more details.
-
-=head3 lighttpd
-
-Host in the root path:
-
- fastcgi.server = ( "" =>
- ((
- "socket" => "/tmp/fcgi.sock",
- "check-local" => "disable"
- ))
+=head1 NAME
-Or in the non-root path over TCP:
+Plack::Server::FCGI - DEPRECATED
- fastcgi.server = ( "/foo" =>
- ((
- "host" = "127.0.0.1"
- "port" = "5000"
- "check-local" => "disable"
- ))
+=head1 DESCRIPTION
-Plack::Server::FCGI has a workaround for lighttpd's weird
-C<SCRIPT_NAME> and C<PATH_INFO> setting when you set I<check-local> to
-C<disable> so both configurations (root or non-root) should work fine.
+B<This module is deprecated>. See L<Plack::Handler::FCGI>.
=cut
@@ -0,0 +1 @@
+This directory and files exist for the backward compatiblities before 0.9032.
@@ -0,0 +1,27 @@
+package Plack::Server::ServerSimple;
+use strict;
+our $VERSION = '0.9911';
+$VERSION = eval $VERSION;
+
+use parent qw(Plack::Handler::HTTP::Server::Simple);
+use Carp;
+
+sub new {
+ my $class = shift;
+ Carp::carp "$class is deprecated. Use -s HTTP::Server::Simple";
+ $class->SUPER::new(@_);
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::Server::ServerSimple - DEPRECATED
+
+=head1 DESCRIPTION
+
+B<DEPRECATED>. Use Plack::Handler::HTTP::Server::Simple.
+
+=cut
@@ -1,37 +1,12 @@
package Plack::Server::Standalone::Prefork;
use strict;
-use warnings;
-
-use parent qw(Plack::Server::Standalone);
-use Parallel::Prefork;
+use parent qw(HTTP::Server::PSGI); # because Standalone is a wrapper
+use Carp;
sub new {
- my($class, %args) = @_;
- my $self = $class->SUPER::new(
- max_keepalive_reqs => 100,
- %args,
- );
- $self->{max_workers} = $args{max_workers} || 10;
- $self->{max_reqs_per_child} = $args{max_reqs_per_child} || 100;
- $self;
-}
-
-sub run {
- my($self, $app) = @_;
- $self->setup_listener();
- my $pm = Parallel::Prefork->new({
- max_workers => $self->{max_workers},
- trap_signals => {
- TERM => 'TERM',
- HUP => 'TERM',
- },
- });
- while ($pm->signal_received ne 'TERM') {
- $pm->start and next;
- $self->accept_loop($app, $self->{max_reqs_per_child});
- $pm->finish;
- }
- $pm->wait_all_children;
+ my $class = shift;
+ Carp::carp "Use of $class is deprecated. Use Plack::Handler::Standalone or Plack::Loader to upgrade.";
+ $class->SUPER::new(@_);
}
1;
@@ -40,51 +15,10 @@ __END__
=head1 NAME
-Plack::Server::Standalone::Prefork - Prefork standalone HTTP server
-
-=head1 SYNOPSIS
-
- % plackup -s Standalone::Prefork \
- --host 127.0.0.1 --port 9091 --timeout 120 \
- --max-keepalive-reqs 20 --keepalive-timeout 5 \
- --max-workers 10 --max-reqs-per-child 320
+Plack::Server::Standalone::Prefork - DEPRECATED
=head1 DESCRIPTION
-Plack::Server::Standalone::Prefork is a prefork standalone HTTP
-server. HTTP/1.0 and Keep-Alive requests are supported.
-
-Some features in HTTP/1.1, notably chunked requests, responses and
-pipeline requests are B<NOT> supported yet.
-
-=head1 CONFIGURATIONS
-
-=over 4
-
-=item host, port, timeout, keepalive-timeout
-
-Same as L<Plack::Server::Standalone>.
-
-=item max-workers
-
-Number of prefork workers. Defaults to 10.
-
-=item max-reqs-per-child
-
-Number of requests per worker to process. Defaults to 100.
-
-=item max-keepalive-reqs
-
-Max requests per a keep-alive request. Defaults to 100.
-
-=back
-
-=head1 AUTHOR
-
-Kazuho Oku
-
-=head1 SEE ALSO
-
-L<Plack::Server::Standalone>
+B<This module is deprecated>. See L<Plack::Handler::Standalone>.
=cut
@@ -1,293 +1,12 @@
package Plack::Server::Standalone;
use strict;
-use warnings;
-
-use Plack;
-use Plack::HTTPParser qw( parse_http_request );
-use IO::Socket::INET;
-use HTTP::Date;
-use HTTP::Status;
-use List::Util qw(max sum);
-use Plack::Util;
-use Plack::Middleware::ContentLength;
-use POSIX qw(EINTR);
-use Socket qw(IPPROTO_TCP TCP_NODELAY);
-
-use Try::Tiny;
-use Time::HiRes qw(time);
-
-my $alarm_interval;
-BEGIN {
- if ($^O eq 'MSWin32') {
- $alarm_interval = 1;
- } else {
- Time::HiRes->import('alarm');
- $alarm_interval = 0.1;
- }
-}
-
-use constant MAX_REQUEST_SIZE => 131072;
-use constant MSWin32 => $^O eq 'MSWin32';
-
-our $HasSendFile = !$ENV{PLACK_NO_SENDFILE} && try { require Sys::Sendfile; 1 };
+use parent qw(Plack::Handler::Standalone);
+use Carp;
sub new {
- my($class, %args) = @_;
- my $self = bless {
- host => $args{host} || 0,
- port => $args{port} || 8080,
- timeout => $args{timeout} || 300,
- max_keepalive_reqs => $args{max_keepalive_reqs} || 1,
- keepalive_timeout => $args{keepalive_timeout} || 2,
- server_software => $args{server_software} || "$class/$Plack::VERSION",
- }, $class;
-
- $self;
-}
-
-sub run {
- my($self, $app) = @_;
- $self->setup_listener();
- $self->accept_loop($app);
-}
-
-sub setup_listener {
- my $self = shift;
- $self->{listen_sock} ||= IO::Socket::INET->new(
- Listen => SOMAXCONN,
- LocalPort => $self->{port},
- LocalAddr => $self->{host},
- Proto => 'tcp',
- ReuseAddr => 1,
- ) or die "failed to listen to port $self->{port}:$!";
- warn ref($self), ": Accepting connections at http://$self->{host}:$self->{port}/\n";
-}
-
-sub accept_loop {
- # TODO handle $max_reqs_per_child
- my($self, $app, $max_reqs_per_child) = @_;
- my $proc_req_count = 0;
-
- $app = Plack::Middleware::ContentLength->wrap($app);
-
- while (! defined $max_reqs_per_child || $proc_req_count < $max_reqs_per_child) {
- local $SIG{PIPE} = 'IGNORE';
- if (my $conn = $self->{listen_sock}->accept) {
- $conn->setsockopt(IPPROTO_TCP, TCP_NODELAY, 1)
- or die "setsockopt(TCP_NODELAY) failed:$!";
- my $req_count = 0;
- while (1) {
- ++$req_count;
- ++$proc_req_count;
- my $env = {
- SERVER_PORT => $self->{port},
- SERVER_NAME => $self->{host},
- SCRIPT_NAME => '',
- REMOTE_ADDR => $conn->peerhost,
- 'psgi.version' => [ 1, 0 ],
- 'psgi.errors' => *STDERR,
- 'psgi.url_scheme' => 'http',
- 'psgi.run_once' => Plack::Util::FALSE,
- 'psgi.multithread' => Plack::Util::FALSE,
- 'psgi.multiprocess' => Plack::Util::FALSE,
- 'psgi.streaming' => Plack::Util::TRUE,
- };
-
- # no need to take care of pipelining since this module is a HTTP/1.0 server
- my $may_keepalive = $req_count < $self->{max_keepalive_reqs};
- if ($may_keepalive && $max_reqs_per_child && $proc_req_count >= $max_reqs_per_child) {
- $may_keepalive = undef;
- }
- $self->handle_connection($env, $conn, $app, $may_keepalive, $req_count != 1)
- or last;
- # TODO add special cases for clients with broken keep-alive support, as well as disabling keep-alive for HTTP/1.0 proxies
- }
- }
- }
-}
-
-sub handle_connection {
- my($self, $env, $conn, $app, $use_keepalive, $is_keepalive) = @_;
-
- my $buf = '';
- my $res = [ 400, [ 'Content-Type' => 'text/plain' ], [ 'Bad Request' ] ];
-
- while (1) {
- my $rlen = $self->read_timeout(
- $conn, \$buf, MAX_REQUEST_SIZE - length($buf), length($buf),
- $is_keepalive ? $self->{keepalive_timeout} : $self->{timeout},
- ) or return;
- my $reqlen = parse_http_request($buf, $env);
- if ($reqlen >= 0) {
- # handle request
- if ($use_keepalive) {
- if (my $c = $env->{HTTP_CONNECTION}) {
- $use_keepalive = undef
- unless $c =~ /^\s*keep-alive\s*/i;
- } else {
- $use_keepalive = undef;
- }
- }
- $buf = substr $buf, $reqlen;
- if ($env->{CONTENT_LENGTH}) {
- # TODO can $conn seek to the begining of body and then set to 'psgi.input'?
- while (length $buf < $env->{CONTENT_LENGTH}) {
- $self->read_timeout($conn, \$buf, $env->{CONTENT_LENGTH} - length($buf), length($buf), $self->{timeout})
- or return;
- }
- }
-
- open my $input, "<", \$buf;
- $env->{'psgi.input'} = $input;
- $res = Plack::Util::run_app $app, $env;
- last;
- }
- if ($reqlen == -2) {
- # request is incomplete, do nothing
- } elsif ($reqlen == -1) {
- # error, close conn
- last;
- }
- }
-
- if (ref $res eq 'ARRAY') {
- $self->_handle_response($res, $conn, \$use_keepalive);
- } elsif (ref $res eq 'CODE') {
- $res->(sub {
- $self->_handle_response($_[0], $conn, \$use_keepalive);
- });
- } else {
- die "Bad response $res";
- }
-
- return $use_keepalive;
-}
-
-sub _handle_response {
- my($self, $res, $conn, $use_keepalive_r) = @_;
-
- my @lines = (
- "Date: @{[HTTP::Date::time2str()]}\015\012",
- "Server: $self->{server_software}\015\012",
- );
-
- Plack::Util::header_iter($res->[1], sub {
- my ($k, $v) = @_;
- if (lc $k eq 'connection') {
- $$use_keepalive_r = undef
- if $$use_keepalive_r && lc $v ne 'keep-alive';
- } else {
- push @lines, "$k: $v\015\012";
- }
- });
- if ($$use_keepalive_r) {
- $$use_keepalive_r = undef
- unless Plack::Util::header_exists($res->[1], 'Content-Length');
- }
- push @lines, "Connection: keep-alive\015\012"
- if $$use_keepalive_r;
- unshift @lines, "HTTP/1.0 $res->[0] @{[ HTTP::Status::status_message($res->[0]) ]}\015\012";
- push @lines, "\015\012";
-
- $self->write_all($conn, join('', @lines), $self->{timeout})
- or return;
-
- if ($HasSendFile && Plack::Util::is_real_fh($res->[2])) {
- $self->sendfile_all($conn, $res->[2], $self->{timeout});
- } elsif (defined $res->[2]) {
- my $err;
- my $done;
- {
- local $@;
- eval {
- Plack::Util::foreach(
- $res->[2],
- sub {
- $self->write_all($conn, $_[0], $self->{timeout})
- or die "failed to send all data\n";
- },
- );
- $done = 1;
- };
- $err = $@;
- };
- unless ($done) {
- if ($err =~ /^failed to send all data\n/) {
- return;
- } else {
- die $err;
- }
- }
- } else {
- return Plack::Util::inline_object
- write => sub { $self->write_all($conn, $_[0], $self->{timeout}) },
- close => sub { };
- }
-}
-
-# returns 1 if socket is ready, undef on timeout
-sub do_timeout {
- my ($self, $cb, $timeout) = @_;
- local $SIG{ALRM} = sub {};
- my $wait_until = time + $timeout;
- alarm($timeout);
- my $ret;
- while (1) {
- if ($ret = $cb->()) {
- last;
- } elsif (! (! defined($ret) && $! == EINTR)) {
- undef $ret;
- last;
- }
- # got EINTR
- my $left = $wait_until - time;
- last if $left <= 0;
- alarm($left + $alarm_interval);
- }
- alarm(0);
- $ret;
-}
-
-# returns (positive) number of bytes read, or undef if the socket is to be closed
-sub read_timeout {
- my ($self, $sock, $buf, $len, $off, $timeout) = @_;
- $self->do_timeout(sub { $sock->sysread($$buf, $len, $off) }, $timeout);
-}
-
-# returns (positive) number of bytes written, or undef if the socket is to be closed
-sub write_timeout {
- my ($self, $sock, $buf, $len, $off, $timeout) = @_;
- $self->do_timeout(sub { $sock->syswrite($buf, $len, $off) }, $timeout);
-}
-
-# writes all data in buf and returns number of bytes written or undef if failed
-sub write_all {
- my ($self, $sock, $buf, $timeout) = @_;
- my $off = 0;
- while (my $len = length($buf) - $off) {
- my $ret = $self->write_timeout($sock, $buf, $len, $off, $timeout)
- or return;
- $off += $ret;
- }
- return length $buf;
-}
-
-sub sendfile_all {
- # TODO fallback to write_all
- my ($self, $sock, $fd, $timeout) = @_;
- my $off = 0;
- my $len = -s $fd;
- die "TODO" unless defined $len;
- while ($off < $len) {
- my $r = $self->do_timeout(
- sub { Sys::Sendfile::sendfile($sock, $fd, $len - $off, $off) },
- $timeout,
- );
- return
- unless defined $r;
- $off += $r;
- }
- return $off;
+ my $class = shift;
+ Carp::carp "Use of $class is deprecated. Use Plack::Handler::Standalone or Plack::Loader to upgrade.";
+ $class->SUPER::new(@_);
}
1;
@@ -296,60 +15,10 @@ __END__
=head1 NAME
-Plack::Server::Standalone - single process standalone HTTP server
-
-=head1 SYNOPSIS
-
- % plackup -s Standalone \
- --host 127.0.0.1 --port 9091 --timeout 120
+Plack::Server::Standalone - DEPRECATED
=head1 DESCRIPTION
-Plack::Server::Standalone is a default Plack server implementation
-that runs as a standalone, single-process and reasonably fast HTTP
-server. HTTP/1.0 and Keep-Alive requests are supported.
-
-This server should be great for the development and testing, but not
-suitable for production. See L<Plack::Server::Standalone::Prefork> if
-you want a multi-process prefork server.
-
-Some features in HTTP/1.1, notably chunked requests, responses and
-pipeline requests are B<NOT> supported yet.
-
-=head1 CONFIGURATIONS
-
-=over 4
-
-=item host
-
-Host the server binds to. Defaults to all interfaces.
-
-=item port
-
-Port number the server listens on. Defaults to 8080.
-
-=item timeout
-
-Number of seconds a request times out. Defaults to 300.
-
-=item max-keepalive-reqs
-
-Max requests per a keep-alive request. Defaults to 1, which means Keep-alive is off.
-
-=item keepalive-timeout
-
-Number of seconds a keep-alive request times out. Defaults to 2.
-
-=back
-
-=head1 AUTHOR
-
-Kazuho Oku
-
-Tatsuhiko Miyagawa
-
-=head1 SEE ALSO
-
-L<Plack::Server::Standalone::Prefork>
+B<This module is deprecated>. See L<Plack::Handler::Standalone>.
=cut
@@ -7,74 +7,11 @@ __END__
=head1 NAME
-Plack::Server - Standard interface for Plack implementations
-
-=head1 SYNOPSIS
-
- package FooBarServer;
- sub new {
- my($class, %opt) = @_;
- ...
- return $self;
- }
-
- sub run {
- my($self, $app) = @_;
- # launch the server and run $app in the loop
- }
-
- # then from command line
- plackup -s +FooBarServer -a app.psgi
-
-=head1 DESCRIPTION
-
-Plack::Server is an abstract interface (but not actually a base class)
-of Plack PSGI implementations. As long as they implement the methods
-defined as an Server unified interface, they do not need to inherit
-Plack::Server.
-
-=head1 METHODS
-
-=over 4
-
-=item new
-
- $server = FooBarServer->new(%args);
-
-Creates a new implementation object. I<%args> can take arbitrary
-parameters per implementations but common parameters are:
-
-=over 8
-
-=item port
-
-Port number the server listens to.
-
-=item host
-
-Address the server listens to. Set to undef to listen any interface.
-
-=back
-
-=item run
-
- $server->run($app);
-
-Starts the server process and when a request comes in, run the PSGI application passed in C<$app> in the loop.
-
-=item register_service
-
- $server->register_service($app);
-
-Optional interface if your server should run in parallel with other
-event loop, particularly L<AnyEvent>. This is the same as C<run> but
-doesn't run the main loop.
-
-=back
+Plack::Server - DEPRECATED. See Plack::Handler
=head1 SEE ALSO
-rackup
+L<Plack::Handler>
=cut
@@ -0,0 +1,35 @@
+package Plack::TempBuffer::Auto;
+use strict;
+use parent 'Plack::TempBuffer';
+
+sub new {
+ my($class, undef, $max_memory_size) = @_;
+ bless {
+ _buffer => Plack::TempBuffer->create('PerlIO'),
+ _max => $max_memory_size,
+ }, $class;
+}
+
+sub print {
+ my $self = shift;
+ $self->{_buffer}->print(@_);
+
+ if ($self->{_max} && $self->{_buffer}->size > $self->{_max}) {
+ my $buf = $self->{_buffer}->{buffer};
+ $self->{_buffer} = Plack::TempBuffer->create('File'),
+ $self->{_buffer}->print($buf);
+ delete $self->{_max};
+ }
+}
+
+sub size {
+ my $self = shift;
+ $self->{_buffer}->size;
+}
+
+sub rewind {
+ my $self = shift;
+ $self->{_buffer}->rewind;
+}
+
+1;
@@ -0,0 +1,33 @@
+package Plack::TempBuffer::File;
+use strict;
+use parent 'Plack::TempBuffer';
+
+use IO::File;
+
+sub new {
+ my $class = shift;
+
+ my $fh = IO::File->new_tmpfile;
+ $fh->binmode;
+
+ bless { fh => $fh }, $class;
+}
+
+sub print {
+ my $self = shift;
+ $self->{fh}->print(@_);
+}
+
+sub size {
+ my $self = shift;
+ $self->{fh}->flush;
+ -s $self->{fh};
+}
+
+sub rewind {
+ my $self = shift;
+ $self->{fh}->seek(0, 0);
+ $self->{fh};
+}
+
+1;
@@ -0,0 +1,28 @@
+package Plack::TempBuffer::PerlIO;
+use strict;
+use parent 'Plack::TempBuffer';
+
+sub new {
+ my $class = shift;
+ bless { buffer => '' }, $class;
+}
+
+sub print {
+ my $self = shift;
+ $self->{buffer} .= "@_";
+}
+
+sub size {
+ my $self = shift;
+ length $self->{buffer};
+}
+
+sub rewind {
+ my $self = shift;
+ my $buffer = $self->{buffer};
+ open my $io, "<", \$buffer;
+ bless $io, 'FileHandle'; # This makes $io work as FileHandle under 5.8, .10 and .11 :/
+ return $io;
+}
+
+1;
@@ -0,0 +1,67 @@
+package Plack::TempBuffer;
+use strict;
+use warnings;
+use Plack::Util;
+use FileHandle; # for seek etc.
+
+our $MaxMemoryBufferSize = 1024 * 1024;
+
+sub new {
+ my($class, $length) = @_;
+
+ # $MaxMemoryBufferSize = 0 -> Always temp file
+ # $MaxMemoryBufferSize = -1 -> Always PerlIO
+ my $backend;
+ if ($MaxMemoryBufferSize < 0) {
+ $backend = "PerlIO";
+ } elsif ($MaxMemoryBufferSize == 0) {
+ $backend = "File";
+ } elsif (!$length) {
+ $backend = "Auto";
+ } elsif ($length > $MaxMemoryBufferSize) {
+ $backend = "File";
+ } else {
+ $backend = "PerlIO";
+ }
+
+ $class->create($backend, $length, $MaxMemoryBufferSize);
+}
+
+sub create {
+ my($class, $backend, $length, $max) = @_;
+ Plack::Util::load_class($backend, $class)->new($length, $max);
+}
+
+sub print;
+sub rewind;
+sub size;
+
+1;
+
+__END__
+
+=head1 NAME
+
+Plack::TempBuffer - temporary buffer to save bytes
+
+=head1 SYNOPSIS
+
+ my $buf = Plack::TempBuffer->new($length);
+ $buf->print($bytes);
+
+ my $size = $buf->size;
+ my $fh = $buf->rewind;
+
+=head1 DESCRIPTION
+
+Plack::TempBuffer is a buffer class to store arbitrary length of byte
+strings and then get a seekable filehandle once everything is
+buffered. It uses PerlIO and/or temporary file to save the buffer
+depending on the length of the size.
+
+=head1 SEE ALSO
+
+L<Plack> L<Plack::Request>
+
+=cut
+
@@ -64,6 +64,42 @@ our @TEST = (
},
],
[
+ 'big POST',
+ sub {
+ my $cb = shift;
+ my $chunk = "abcdefgh" x 12000;
+ my $req = HTTP::Request->new(POST => "http://127.0.0.1");
+ $req->content_length(length $chunk);
+ $req->content_type('application/octet-stream');
+ $req->content($chunk);
+
+ my $res = $cb->($req);
+ is $res->code, 200;
+ is $res->header('Client-Content-Length'), length $chunk;
+ is length $res->content, length $chunk;
+ is Digest::MD5::md5_hex($res->content), Digest::MD5::md5_hex($chunk);
+ },
+ sub {
+ my $env = shift;
+ my $len = $env->{CONTENT_LENGTH};
+ my $body = '';
+ my $spin;
+ while ($len > 0) {
+ my $rc = $env->{'psgi.input'}->read($body, $env->{CONTENT_LENGTH}, length $body);
+ $len -= $rc;
+ last if $spin++ > 2000;
+ }
+ return [
+ 200,
+ [ 'Content-Type' => 'text/plain',
+ 'Client-Content-Length' => $env->{CONTENT_LENGTH},
+ 'Client-Content-Type' => $env->{CONTENT_TYPE},
+ ],
+ [ $body ],
+ ];
+ },
+ ],
+ [
'psgi.url_scheme',
sub {
my $cb = shift;
@@ -350,7 +386,7 @@ our @TEST = (
},
],
[
- 'multi headers',
+ 'multi headers (request)',
sub {
my $cb = shift;
my $req = HTTP::Request->new(
@@ -359,7 +395,7 @@ our @TEST = (
$req->push_header(Foo => "bar");
$req->push_header(Foo => "baz");
my $res = $cb->($req);
- is($res->content, "bar, baz");
+ like($res->content, qr/^bar,\s*baz$/);
},
sub {
my $env = shift;
@@ -371,6 +407,44 @@ our @TEST = (
},
],
[
+ 'multi headers (response)',
+ sub {
+ my $cb = shift;
+ my $res = $cb->(HTTP::Request->new(GET => "http://127.0.0.1/"));
+ my $foo = $res->header('X-Foo');
+ like $foo, qr/foo,\s*bar,\s*baz/;
+ },
+ sub {
+ my $env = shift;
+ return [
+ 200,
+ [ 'Content-Type' => 'text/plain', 'X-Foo', 'foo', 'X-Foo', 'bar, baz' ],
+ [ 'hi' ]
+ ];
+ },
+ ],
+ [
+ 'Do not set $env->{COOKIE}',
+ sub {
+ my $cb = shift;
+ my $req = HTTP::Request->new(
+ GET => "http://127.0.0.1/",
+ );
+ $req->push_header(Cookie => "foo=bar");
+ my $res = $cb->($req);
+ is($res->header('X-Cookie'), 0);
+ is $res->content, 'foo=bar';
+ },
+ sub {
+ my $env = shift;
+ return [
+ 200,
+ [ 'Content-Type' => 'text/plain', 'X-Cookie' => $env->{COOKIE} ? 1 : 0 ],
+ [ $env->{HTTP_COOKIE} ]
+ ];
+ },
+ ],
+ [
'no entity headers on 304',
sub {
my $cb = shift;
@@ -390,8 +464,8 @@ our @TEST = (
'REQUEST_URI is set',
sub {
my $cb = shift;
- my $res = $cb->(GET "http://127.0.0.1/foo/bar%20baz?x=a");
- is $res->content, '/foo/bar%20baz?x=a';
+ my $res = $cb->(GET "http://127.0.0.1/foo/bar%20baz%73?x=a");
+ is $res->content, '/foo/bar%20baz%73?x=a';
},
sub {
my $env = shift;
@@ -504,6 +578,18 @@ our @TEST = (
return [ 200, [ "Content-Type", "text/plain" ], [ "Foo: Bar\r\n\r\nHello World" ] ];
},
],
+ [
+ 'test 404',
+ sub {
+ my $cb = shift;
+ my $res = $cb->(GET "http://127.0.0.1/");
+ is $res->code, 404;
+ is $res->content, 'Not Found';
+ },
+ sub {
+ return [ 404, [ "Content-Type", "text/plain" ], [ "Not Found" ] ];
+ },
+ ],
);
sub runtests {
@@ -514,13 +600,13 @@ sub runtests {
}
sub run_server_tests {
- my($class, $server, $server_port, $http_port) = @_;
+ my($class, $server, $server_port, $http_port, %args) = @_;
if (ref $server ne 'CODE') {
my $server_class = $server;
$server = sub {
my($port, $app) = @_;
- my $server = Plack::Loader->load($server_class, port => $port, host => "127.0.0.1");
+ my $server = Plack::Loader->load($server_class, port => $port, host => "127.0.0.1", %args);
$app = Plack::Middleware::Lint->wrap($app);
$server->run($app);
}
@@ -11,7 +11,7 @@ sub test_psgi {
eval "require Plack::Test::$Impl;";
die $@ if $@;
no strict 'refs';
- if (@_ == 2) {
+ if (ref $_[0] && @_ == 2) {
@_ = (app => $_[0], client => $_[1]);
}
&{"Plack::Test::$Impl\::test_psgi"}(@_);
@@ -59,7 +59,7 @@ Plack::Test is an unified interface to test PSGI applications using
standard HTTP::Request and HTTP::Response objects. It also allows you
to run PSGI applications in various ways, by default using C<MockHTTP>
backend but can also use C<Server> backend, which uses one of
-L<Plack::Server> implementations to run the web server to do live HTTP
+L<Plack::Handler> implementations to run the web server to do live HTTP
requests.
=head1 FUNCTIONS
@@ -104,9 +104,15 @@ the PSGI application in-process and returns HTTP::Response.
=item Server
-Runs one of Plack::Server backends (C<Standalone> by default) and
+Runs one of Plack::Handler backends (C<Standalone> by default) and
sends live HTTP requests to test.
+=item ExternalServer
+
+Runs tests against an external server specified in the
+C<PLACK_TEST_EXTERNALSERVER_URI> environment variable instead of spawning the
+application in a server locally.
+
=back
For instance, you can test your application with C<ServerSimple> server backends with:
@@ -43,4 +43,4 @@ L<PSGI> L<http://plackperl.org/>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
\ No newline at end of file
+=cut
@@ -3,7 +3,7 @@ use strict;
use Carp ();
use Scalar::Util;
use IO::Handle;
-use Try::Tiny;
+use overload ();
sub TRUE() { 1==1 }
sub FALSE() { !TRUE }
@@ -103,7 +103,7 @@ sub load_psgi {
my $stuff = shift;
my $file = $stuff =~ /^[a-zA-Z0-9\_\:]+$/ ? class_to_file($stuff) : $stuff;
- my $app = require $file;
+ my $app = do $file;
return $app->to_app if $app and Scalar::Util::blessed($app) and $app->can('to_app');
return $app if $app and (ref $app eq 'CODE' or overload::Method($app, '&{}'));
@@ -117,13 +117,11 @@ sub load_psgi {
sub run_app($$) {
my($app, $env) = @_;
- return try {
- $app->($env);
- } catch {
+ return eval { $app->($env) } || do {
my $body = "Internal Server Error";
- $env->{'psgi.errors'}->print($_);
- return [ 500, [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ], [ $body ] ];
- }
+ $env->{'psgi.errors'}->print($@);
+ [ 500, [ 'Content-Type' => 'text/plain', 'Content-Length' => length($body) ], [ $body ] ];
+ };
}
sub headers {
@@ -232,11 +230,11 @@ sub can {
}
sub AUTOLOAD {
- my ($self, @args) = @_;
+ my $self = shift;
my $attr = $AUTOLOAD;
$attr =~ s/.*://;
if (ref($self->{$attr}) eq 'CODE') {
- $self->{$attr}->(@args);
+ $self->{$attr}->(@_);
} else {
Carp::croak(qq/Can't locate object method "$attr" via package "Plack::Util::Prototype"/);
}
@@ -354,7 +352,7 @@ considered very insecure. But if you really want to do that, be sure
to validate the argument passed to this function. Also, if you do not
want to accept an arbitrary class name but only load from a file path,
make sure that the argument C<$psgi_file_or_class> begins with C</> so
-that Perl's built-in require function won't search the include path.
+that Perl's built-in do function won't search the include path.
=item run_app
@@ -3,36 +3,39 @@ package Plack;
use strict;
use warnings;
use 5.008_001;
-our $VERSION = '0.9031';
+our $VERSION = '0.9911';
+$VERSION = eval $VERSION;
1;
__END__
=head1 NAME
-Plack - PSGI toolkit and servers
+Plack - Perl Superglue for Web frameworks and Web Servers (PSGI toolkit)
=head1 DESCRIPTION
-Plack is a set of PSGI reference server implementations and helper
-utilities for Web application frameworks, exactly like Ruby's Rack.
+Plack is a set of tools for using PSGI stack. It contains middleware
+components, a reference server and utilities for Web application
+frameworks. Plack is like Ruby's Rack or Python's Paste for WSGI.
See L<PSGI> for the PSGI specification and L<PSGI::FAQ> to know what
PSGI and Plack are and why we need them.
=head1 MODULES AND UTILITIES
-=head2 Plack::Server
+=head2 Plack::Handler
-L<Plack::Server> is a namespace for PSGI server implementations. We
-have Standalone, CGI, FCGI, Apache, AnyEvent, Coro, Danga::Socket and
-many server environments that you can run PSGI applications on.
+L<Plack::Handler> and its subclasses contains adapters for web
+servers. We have adapters for Standalone, CGI, FCGI, Apache, AnyEvent,
+Coro, Danga::Socket and many server environments that you can run PSGI
+applications on.
-See L<Plack::Server> how to write your own server implementation.
+See L<Plack::Handler> how to write your own adapters.
=head2 Plack::Loader
-L<Plack::Loader> is a loader to load one of Plack::Server backends and
+L<Plack::Loader> is a loader to load one of Plack::Server adapters and
run PSGI application code reference with it.
=head2 Plack::Util
@@ -46,8 +49,26 @@ PSGI application is a code reference but it's not easy to pass code
reference in the command line or configuration files, so Plack uses a
convention that you need a file named C<app.psgi> or alike, which
would be loaded (via perl's core function C<do>) to return the PSGI
-application code reference. See eg/dot-psgi directory for the example
-C<.psgi> files.
+application code reference.
+
+ # Hello.psgi
+ my $app = sub {
+ my $env = shift;
+ # ...
+ return [ $status, $headers, $body ];
+ };
+
+If you use a web framework, chances are that they provide a helper
+utility to automatically generate these C<.psgi> files for you, such
+as:
+
+ # MyApp.psgi
+ use MyApp;
+ my $app = sub { MyApp->run_psgi(@_) };
+
+It's important that the return value of C<.psgi> file is the code
+reference. See eg/dot-psgi directory for more examples of C<.psgi>
+files.
=head2 plackup, Plack::Runner
@@ -131,17 +152,45 @@ confuse people.
Copyright 2009- Tatsuhiko Miyagawa
-=head1 AUTHORS
+=head1 AUTHOR
Tatsuhiko Miyagawa
-Yuval Kogman
+=head1 CONTRIBUTORS
+
+Yuval Kogman (nothingmuch)
+
+Tokuhiro Matsuno (tokuhirom)
+
+Kazuhiro Osawa (Yappo)
+
+Kzzuho Oku
+
+Florian Ragwitz (rafl)
+
+Chia-liang Kao (clkao)
+
+Masahiro Honma (hiratara)
+
+Daisuke Murase (typester)
+
+John Beppu
+
+Matt S Trout (mst)
+
+Shawn M Moore (Sartak)
+
+Stevan Little
+
+Hans Dieter Pearcey (confound)
+
+Tomas Doran (t0m)
-Tokuhiro Matsuno
+mala
-Kazuhiro Osawa
+Mark Stosberg
-Kazuho Oku
+Aaron Trevena
=head1 SEE ALSO
@@ -3,7 +3,9 @@ use strict;
use lib "lib";
use Plack::Runner;
-Plack::Runner->run(@ARGV);
+my $runner = Plack::Runner->new;
+$runner->parse_options(@ARGV);
+$runner->run;
__END__
@@ -20,7 +22,13 @@ plackup - Run PSGI application with Plack servers
plackup hello.psgi
# Switch server implementation with --server (or -s)
- plackup --server Coro --port 9090 --host 127.0.0.1 test.psgi
+ plackup --server HTTP::Server::Simple --port 9090 --host 127.0.0.1 test.psgi
+
+ # Use UNIX socket to run FCGI daemon
+ plackup -s FCGI --listen /tmp/fcgi.sock myapp.psgi
+
+ # FCGI external server on port 9090
+ plackup -s FCGI --port 9090
=head1 DESCRIPTION
@@ -75,13 +83,14 @@ option.
The interface a TCP based server daemon binds to. Defauts to undef,
which lets most server backends bind the any (*) interface. This
-opeion doesn't mean anything if the server is not TCP based.
+opeion doesn't mean anything if the server does not support TCP
+socket.
=item -p, --port
The port number a TCP based server daemon listens on. Defaults to
-5000. This option doesn't mean anything if the server is not TCP
-based.
+5000. This option doesn't mean anything if the server does not support
+TCP socket.
=item -s, --server
@@ -89,6 +98,22 @@ Select a specific implementation to run on using the C<PLACK_SERVER>
environment variable or use the C<-s> or C<--server> flag which will
be prefered over the environment variable if present.
+=item -S, --socket
+
+UNIX domain socket path to listen on. Defaults to undef. This option
+doesn't mean anything if the server doesn't support UNIX sockets.
+
+=item -l, --listen
+
+Addresses to listen on. It could be "HOST:PORT", ":PORT" or "PATH"
+(without colons). It could be multiple but it depends on the server
+implementations whether multiple interfaces are supported.
+
+=item -D, --daemonize
+
+Makes the process go background. It's up to the backend server/handler
+implementation whether this option is respected or not.
+
=item -I
Specify perl library include path, like C<perl>'s -I option.
@@ -99,16 +124,28 @@ Specify modules to load before loading the app code.
=item -E, --env
-Specify the environment option (default is C<development>). If it's
-set to C<development>, following middleware is enabled by default:
-L<CommonLogger>, L<StackTrace>.
+Specify the environment option (default is C<development>). You can
+set this value by setting C<PLACK_ENV> environment variable as well,
+and specifying the value with the command line options writes back to
+C<PLACK_ENV> as well, so applications or frameworks can tell which
+environment setting the application is running on.
+
+ # These two are the same
+ plackup -E deployment
+ env PLACK_ENV=deployment plackup
+
+The value can be anything but commonly used ones are C<development>,
+C<deployment> and C<test>.
+
+If it's set to C<development>, following middleware is enabled by
+default: L<AccessLog>, L<StackTrace>.
=item -r, --reload
Make plackup to watch updates from your development directory and
restarts the server whenever a file is updated. This option by default
-watches the current directory. Use C<-R> if you want to watch other
-directories.
+watches the C<lib> directory and the base directory where I<.psgi>
+file is located. Use C<-R> if you want to watch other directories.
=item -R, --Reload
@@ -117,6 +154,12 @@ separated by comma (C<,>).
plackup -R /path/to/project/lib,/path/to/project/templates
+=item -L, --loader
+
+Specify the server loading subclass that implements how to run the
+server. Available options are I<Plack::Loader> (default), I<Restarter>
+(automatically set when C<-r> or C<-R> is used) and I<Shotgun>.
+
=back
Other options that starts with C<--> are passed through to the backend
@@ -0,0 +1,23 @@
+use Test::More;
+use Encode;
+use HTTP::Request;
+use HTTP::Message::PSGI;
+
+my @paths = (
+ 'П', '%D0%9F',
+ decode_utf8('П'), '%D0%9F',
+ 'À', '%C3%80',
+ decode_utf8('À'), '%C3%80',
+);
+
+while (my($raw, $encoded) = splice @paths, 0, 2) {
+ my $req = HTTP::Request->new(GET => "http://localhost/" . $raw);
+ my $env = $req->to_psgi;
+ is $env->{REQUEST_URI}, "/$encoded";
+ is $env->{PATH_INFO}, URI::Escape::uri_unescape("/$encoded");
+ ok !utf8::is_utf8 $env->{PATH_INFO};
+ ok !utf8::is_utf8 $env->{HTTP_HOST};
+}
+
+done_testing;
+
@@ -0,0 +1,82 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires qw(Apache::Constants);
+use Plack;
+use Test::TCP;
+use LWP::UserAgent;
+use FindBin;
+use File::Path;
+
+use Plack::Test::Suite;
+
+plan skip_all => "TEST_APACHE1 is not set"
+ unless $ENV{TEST_APACHE1};
+
+Plack::Test::Suite->run_server_tests(\&run_httpd);
+done_testing();
+
+my $log_filename;
+
+sub run_httpd {
+ my $port = shift;
+
+ my $tmpdir = $ENV{APACHE1_TMP_DIR} || File::Temp::tempdir( CLEANUP => 1 );
+
+ my $httpd = $ENV{APACHE_BIN} || 'httpd';
+
+ write_file("$tmpdir/app.psgi", _render_psgi());
+ write_file("$tmpdir/httpd.conf", _render_conf($tmpdir, $port, "$tmpdir/app.psgi"));
+ mkpath( "$tmpdir/conf" );
+ write_file("$tmpdir/conf/mime.types", _render_mimetypes());
+
+
+ $log_filename = "$tmpdir/error_log";
+ system ("touch $log_filename");
+ link($log_filename, 'err');
+
+ exec "$httpd -X -F -f $tmpdir/httpd.conf" or die "couldn't start httpd : $!\n";
+}
+
+
+sub write_file {
+ my($path, $content) = @_;
+
+ open my $out, ">", $path or die "$path: $!";
+ print $out $content;
+}
+
+sub _render_mimetypes {
+ return 'text/html html htm';
+}
+
+
+sub _render_psgi {
+ return <<'EOF';
+use lib "lib";
+use Plack::Test::Suite;
+
+Plack::Test::Suite->test_app_handler;
+EOF
+}
+
+sub _render_conf {
+ my ($tmpdir, $port, $psgi_path) = @_;
+ my $load_module = ( -f "$tmpdir/libexec/mod_perl.so" ) ? 'LoadModule perl_module libexec/mod_perl.so' : '' ;
+ my $conf = <<"END";
+$load_module
+ServerRoot $tmpdir
+ServerName 127.0.0.1
+PidFile $tmpdir/httpd.pid
+LockFile $tmpdir/httpd.lock
+ErrorLog $tmpdir/error_log
+Listen $port
+
+<Location />
+SetHandler perl-script
+PerlHandler Plack::Handler::Apache1
+PerlSetVar psgi_app $tmpdir/app.psgi
+</Location>
+END
+ return $conf;
+}
@@ -0,0 +1,67 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires qw(Apache2::Const);
+use Plack;
+use Test::TCP;
+use LWP::UserAgent;
+use FindBin;
+use Plack::Test::Suite;
+
+plan skip_all => "TEST_APACHE2 is not set"
+ unless $ENV{TEST_APACHE2};
+
+# Note: you need to load 64bit lib to test Apache2 on OS X 10.5 or later
+
+Plack::Test::Suite->run_server_tests(\&run_httpd);
+done_testing();
+
+sub run_httpd {
+ my $port = shift;
+
+ my $tmpdir = $ENV{APACHE2_TMP_DIR} || File::Temp::tempdir( CLEANUP => 1 );
+
+ write_file("$tmpdir/app.psgi", _render_psgi());
+ write_file("$tmpdir/httpd.conf", _render_conf($tmpdir, $port, "$tmpdir/app.psgi"));
+
+ exec "httpd -X -D FOREGROUND -f $tmpdir/httpd.conf";
+}
+
+sub write_file {
+ my($path, $content) = @_;
+
+ open my $out, ">", $path or die "$path: $!";
+ print $out $content;
+}
+
+sub _render_psgi {
+ return <<'EOF';
+use lib "lib";
+use Plack::Test::Suite;
+
+Plack::Test::Suite->test_app_handler;
+EOF
+}
+
+sub _render_conf {
+ my ($tmpdir, $port, $psgi_path) = @_;
+ <<"END";
+LoadModule perl_module libexec/apache2/mod_perl.so
+ServerRoot $tmpdir
+PidFile $tmpdir/httpd.pid
+LockFile $tmpdir/httpd.lock
+ErrorLog $tmpdir/error_log
+Listen $port
+
+<Perl>
+use Plack::Handler::Apache2;
+Plack::Handler::Apache2->preload("$tmpdir/app.psgi");
+</Perl>
+
+<Location />
+SetHandler perl-script
+PerlHandler Plack::Handler::Apache2
+PerlSetVar psgi_app $tmpdir/app.psgi
+</Location>
+END
+}
@@ -0,0 +1,33 @@
+use strict;
+use warnings;
+use Test::Requires {
+ 'HTTP::Request::AsCGI' => 1.2,
+};
+use Test::More;
+use FindBin;
+use HTTP::Request::AsCGI;
+use URI::Escape;
+use Plack;
+use Plack::Handler::CGI;
+use Plack::Test::Suite;
+
+Plack::Test::Suite->runtests(sub {
+ my ($name, $test, $handler) = @_;
+
+ note $name;
+ my $cb = sub {
+ my $req = shift;
+
+ my $cgi = HTTP::Request::AsCGI->new($req);
+ my $c = $cgi->setup;
+ eval { Plack::Handler::CGI->new->run($handler) };
+ my $res = $c->response;
+ $res->request($req);
+
+ $res;
+ };
+
+ $test->($cb);
+});
+
+done_testing;
@@ -0,0 +1,35 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires qw(FCGI FCGI::ProcManager);
+use Plack;
+use Plack::Handler::FCGI;
+use Plack::Test::Suite;
+use t::FCGIUtils;
+
+my $lighty_port;
+my $fcgi_port;
+
+test_lighty_external(
+ sub {
+ ($lighty_port, $fcgi_port) = @_;
+ Plack::Test::Suite->run_server_tests(\&run_server, $fcgi_port, $lighty_port);
+ done_testing();
+ }
+);
+
+sub run_server {
+ my($port, $app) = @_;
+
+ $| = 0; # Test::Builder autoflushes this. reset!
+
+ my $server = Plack::Handler::FCGI->new(
+ host => '127.0.0.1',
+ port => $port,
+ manager => '',
+ keep_stderr => 1,
+ );
+ $server->run($app);
+}
+
+
@@ -0,0 +1,41 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires { FCGI => 0, 'FCGI::Client' => 0.04 };
+use Plack;
+use Plack::Handler::FCGI;
+use Test::TCP;
+use LWP::UserAgent;
+use FindBin;
+use Plack::Test::Suite;
+use t::FCGIUtils;
+
+plan skip_all => "Set TEST_FCGI_CLIENT to test this"
+ unless $ENV{TEST_FCGI_CLIENT};
+
+my $http_port;
+my $fcgi_port;
+
+test_fcgi_standalone(
+ sub {
+ ($http_port, $fcgi_port) = @_;
+ Plack::Test::Suite->run_server_tests(\&run_server, $fcgi_port, $http_port);
+ done_testing();
+ }
+);
+
+sub run_server {
+ my($port, $app) = @_;
+
+ $| = 0; # Test::Builder autoflushes this. reset!
+
+ my $server = Plack::Handler::FCGI->new(
+ host => '127.0.0.1',
+ port => $port,
+ manager => '',
+ keep_stderr => 1,
+ );
+ $server->run($app);
+}
+
+
@@ -0,0 +1,10 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires { 'HTTP::Server::Simple::PSGI' => 0.11 };
+use Plack::Test::Suite;
+
+Plack::Test::Suite->run_server_tests('HTTP::Server::Simple');
+done_testing();
+
+
@@ -0,0 +1,15 @@
+use strict;
+use warnings;
+use Test::More;
+use Test::Requires {
+ 'HTTP::Parser::XS' => 0,
+ 'Parallel::Prefork' => 0.04,
+};
+
+use FindBin;
+use Plack;
+use Plack::Test::Suite;
+
+Plack::Test::Suite->run_server_tests('Standalone', undef, undef, max_workers => 10);
+done_testing();
+
@@ -0,0 +1,8 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test::Suite;
+
+Plack::Test::Suite->run_server_tests('Standalone');
+done_testing();
+
@@ -0,0 +1,27 @@
+use strict;
+use Test::More;
+use Plack::Loader;
+
+my $builder = sub {
+ require AnyEvent;
+ my $app = sub {
+ return [ 200, [], [ "Hi" ] ];
+ };
+};
+
+$INC{"Plack/Handler/Twiggy.pm"} = __FILE__;
+sub Plack::Handler::Twiggy::new { bless {}, shift }
+
+eval {
+ my $loader = Plack::Loader->new;
+ $loader->preload_app($builder);
+ my $server = $loader->auto;
+
+ like ref $server, qr/Twiggy/;
+};
+
+ok 1 if $@;
+
+done_testing;
+
+
@@ -0,0 +1,22 @@
+use strict;
+use Test::More;
+use Plack::Loader;
+
+my $builder = sub {
+ my $app = sub {
+ return [ 200, [], [ "Hi" ] ];
+ };
+};
+
+local *Plack::Loader::guess = sub { 'NonExistent' };
+local $SIG{__WARN__} = sub { like $_[0], qr/Autoloading/ };
+
+my $loader = Plack::Loader->new;
+$loader->preload_app($builder);
+my $server = $loader->auto;
+
+like ref $server, qr/Standalone/;
+
+done_testing;
+
+
@@ -0,0 +1,17 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test::Suite;
+use Plack::Loader::Shotgun;
+
+Plack::Test::Suite->run_server_tests(
+ sub {
+ my($port, $app) = @_;
+ my $loader = Plack::Loader::Shotgun->new;
+ $loader->preload_app(sub { $app });
+ my $server = $loader->load('Standalone', port => $port, host => '127.0.0.1');
+ $loader->run($server);
+ },
+);
+
+done_testing();
@@ -0,0 +1,42 @@
+use strict;
+use Test::More;
+use Plack::Builder;
+
+my @tests = (
+ {
+ app => sub {
+ return sub {
+ $_[0]->([ 200, [ 'Content-Type' => 'text/plain' ], [ 'OK' ] ]);
+ },
+ },
+ env => { REQUEST_METHOD => 'GET' },
+ headers => [ 'Content-Type' => 'text/plain' ],
+ body => 'OK',
+ },
+ {
+ app => sub {
+ return sub {
+ my $writer = $_[0]->([ 200, [ 'Content-Type' => 'text/plain' ]]);
+ $writer->write("O");
+ $writer->write("K");
+ $writer->close();
+ },
+ },
+ env => { REQUEST_METHOD => 'GET' },
+ headers => [ 'Content-Type', 'text/plain' ],
+ body => 'OK',
+ },
+);
+
+
+plan tests => 2 * @tests;
+
+for my $block (@tests) {
+ my $handler = builder {
+ enable "BufferedStreaming";
+ $block->{app};
+ };
+ my $res = $handler->($block->{env});
+ is_deeply $res->[1], $block->{headers}, "headers passed through";
+ is join("", @{ $res->[2] }), $block->{body}, "body accumulated";
+};
@@ -0,0 +1,26 @@
+use Plack::Test;
+use Test::More;
+
+use Plack::App::Cascade;
+use HTTP::Request::Common;
+
+my $cascade = Plack::App::Cascade->new;
+$cascade->add( sub { return sub { my $respond = shift; $respond->([ 404, [], [ "Duh" ] ]) } } );
+$cascade->add( sub { return [ 403, [ 'Content-Type', 'text/plain' ], [ "Forbidden" ] ] } );
+$cascade->add( sub { return sub {
+ my $w = shift->([ 200, [ 'Content-Type', 'text/plain' ] ]);
+ $w->write("Hello");
+ $w->close;
+ } });
+
+$cascade->catch([ 403, 404 ]);
+
+test_psgi $cascade, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "http://localhost/");
+ is $res->code, 200;
+ is $res->content, "Hello";
+};
+
+done_testing;
@@ -0,0 +1,3 @@
+use Data::Dumper;
+print "Content-Type: text/plain\r\n\r\n";
+print 'my ' . Dumper \%ENV;
@@ -23,6 +23,18 @@ test_psgi app => $app, client => sub {
is $res->content, "Hello foo counter=1";
$res = $cb->(GET "http://localhost/hello3.cgi");
+ my $env = eval $res->content;
+ is $env->{SCRIPT_NAME}, '/hello3.cgi';
+ is $env->{REQUEST_URI}, '/hello3.cgi';
+
+ $res = $cb->(GET "http://localhost/hello3.cgi/foo%20bar/baz");
+ is $res->code, 200;
+ $env = eval $res->content || {};
+ is $env->{SCRIPT_NAME}, '/hello3.cgi';
+ is $env->{PATH_INFO}, '/foo bar/baz';
+ is $env->{REQUEST_URI}, '/hello3.cgi/foo%20bar/baz';
+
+ $res = $cb->(GET "http://localhost/hello4.cgi");
is $res->code, 404;
};
@@ -16,16 +16,32 @@ my @app = (
sub { [ 200, [], io_from_array [ 'Hello', '', ' World' ] ] },
);
+@app = (@app, @app); # for 1.0 and 1.1
+
my $app = sub { (shift @app)->(@_) };
test_psgi app => Plack::Middleware::Chunked->wrap($app), client => sub {
my $cb = shift;
- for (0..$#app) {
- my $res = $cb->(GET "http://localhost/");
- is $res->content, 'Hello World';
- is $res->decoded_content, 'Hello World';
- is $res->header('client-transfer-encoding'), 'chunked';
+ for my $proto (qw( HTTP/1.1 HTTP/1.0 )) {
+ my $is_http_10 = $proto eq 'HTTP/1.0';
+ if ($is_http_10) {
+ require LWP::Protocol::http10;
+ LWP::Protocol::implementor('http', 'LWP::Protocol::http10');
+ }
+
+ for (1..@app/2) {
+ my $req = GET "http://localhost/";
+ $req->protocol($proto);
+ my $res = $cb->($req);
+ is $res->content, 'Hello World';
+ is $res->decoded_content, 'Hello World';
+ if ($is_http_10) {
+ isnt $res->header('client-transfer-encoding'), 'chunked', 'Chunked shouldn\'t be used in HTTP/1.0';
+ } else {
+ is $res->header('client-transfer-encoding'), 'chunked';
+ }
+ }
}
};
@@ -1,97 +1,61 @@
use strict;
use warnings;
-use Test::Base;
use Plack::Builder;
-
-filters {
- app => 'eval',
- env => 'yaml',
- headers => 'yaml',
-};
-
-plan tests => 2 * blocks;
-
-run {
- my $block = shift;
+use Test::More;
+
+my @tests = (
+ {
+ app => sub { [ 200, [ 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => 'GET' },
+ status => 200,
+ headers => [ 'Content-Type', 'text/plain' ],
+ },
+ {
+ app => sub { [ 200, [ 'ETag' => 'Foo', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => "GET", HTTP_IF_NONE_MATCH => "Foo" },
+ status => 304,
+ headers => [ ETag => 'Foo' ],
+ },
+ {
+ app => sub { [ 200, [ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => "GET", HTTP_IF_MODIFIED_SINCE => "Wed, 23 Sep 2009 13:36:33 GMT" },
+ status => 304,
+ headers => [ "Last-Modified" => "Wed, 23 Sep 2009 13:36:33 GMT" ],
+ },
+ {
+ app => sub { [ 200, [ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => "GET", HTTP_IF_MODIFIED_SINCE => "Wed, 23 Sep 2009 13:36:32 GMT" },
+ status => 200,
+ headers => [
+ "Last-Modified", "Wed, 23 Sep 2009 13:36:33 GMT", "Content-Type", "text/plain",
+ ],
+ },
+ {
+ app => sub { [ 200, [ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => "GET", HTTP_IF_MODIFIED_SINCE => "Wed, 23 Sep 2009 13:36:33 GMT; length=2" },
+ status => 304,
+ headers => [ "Last-Modified", "Wed, 23 Sep 2009 13:36:33 GMT" ],
+ },
+ {
+ app => sub { [ 200, [ 'ETag' => 'Foo', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => "POST", HTTP_IF_NONE_MATCH => "Foo" },
+ status => 200,
+ headers => [ ETag => "Foo", "Content-Type" => "text/plain" ],
+ }
+);
+
+plan tests => 2*@tests;
+
+for my $block (@tests) {
my $handler = builder {
enable "Plack::Middleware::ConditionalGET";
- $block->app;
+ $block->{app};
};
- my $res = $handler->($block->env);
- is $res->[0], $block->status;
- is_deeply $res->[1], $block->headers;
-};
-
-__END__
-
-=== 200 response
---- app
-sub { [ 200, [ 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: GET
---- status: 200
---- headers
-- Content-Type
-- text/plain
-
-=== ETag match
---- app
-sub { [ 200, [ 'ETag' => 'Foo', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: GET
-HTTP_IF_NONE_MATCH: Foo
---- status: 304
---- headers
-- ETag
-- Foo
-
-=== If-Modified-Since match
---- app
-sub { [ 200, [ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: GET
-HTTP_IF_MODIFIED_SINCE: Wed, 23 Sep 2009 13:36:33 GMT
---- status: 304
---- headers
-- Last-Modified
-- Wed, 23 Sep 2009 13:36:33 GMT
-
-=== If-Modified-Since mismatch
---- app
-sub { [ 200, [ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: GET
-HTTP_IF_MODIFIED_SINCE: Wed, 23 Sep 2009 13:36:32 GMT
---- status: 200
---- headers
-- Last-Modified
-- Wed, 23 Sep 2009 13:36:33 GMT
-- Content-Type
-- text/plain
-
-=== If-Modified-Since match ie bug
---- app
-sub { [ 200, [ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: GET
-HTTP_IF_MODIFIED_SINCE: Wed, 23 Sep 2009 13:36:33 GMT; length=2
---- status: 304
---- headers
-- Last-Modified
-- Wed, 23 Sep 2009 13:36:33 GMT
+ my $res = $handler->($block->{env});
+ is $res->[0], $block->{status};
+ is_deeply $res->[1], $block->{headers};
+}
-=== non-GET reqs
---- app
-sub { [ 200, [ 'ETag' => 'Foo', 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: POST
-HTTP_IF_NONE_MATCH: Foo
---- status: 200
---- headers
-- ETag
-- Foo
-- Content-Type
-- text/plain
@@ -1,85 +1,53 @@
use strict;
-use Test::Base;
+use Test::More;
use Plack::Builder;
-filters {
- app => 'eval',
- env => 'yaml',
- headers => 'yaml',
-};
-
-plan tests => 1 * blocks;
-
-run {
- my $block = shift;
+my @tests = (
+ {
+ app => sub { [ 200, [ 'Content-Type' => 'text/plain' ], [ 'OK' ] ] },
+ env => { REQUEST_METHOD => 'GET' },
+ headers=> [ 'Content-Type' => 'text/plain', 'Content-Length' => 2 ],
+ },
+ {
+ app => sub {
+ open my $fh, "<", "share/kyoto.jpg";
+ [ 200, [ 'Content-Type' => 'image/jpeg' ], $fh ];
+ },
+ env => { REQUEST_METHOD => 'GET' },
+ headers => [ 'Content-Type' => 'image/jpeg', 'Content-Length' => 2397701 ],
+ },
+ {
+ app => sub {
+ [ 304, [ ETag => 'Foo' ], [] ];
+ },
+ env => { REQUEST_METHOD => 'GET' },
+ headers => [ ETag => 'Foo' ],
+ },
+ {
+ app => sub {
+ my $body = "Hello World";
+ open my $fh, "<", \$body;
+ [ 200, [ 'Content-Type' => 'text/plain' ], $fh ];
+ },
+ env => { REQUEST_METHOD => 'GET' },
+ headers => [ 'Content-Type' => 'text/plain' ],
+ },
+ {
+ app => sub {
+ [ 200, [ 'Content-Type' => 'text/plain', 'Content-Length' => 11 ], [ "Hello World" ] ];
+ },
+ env => { REQUEST_METHOD => 'GET' },
+ headers => [ 'Content-Type' => 'text/plain', 'Content-Length', 11 ],
+ },
+);
+
+plan tests => 1 * @tests;
+
+for my $block (@tests) {
my $handler = builder {
enable "Plack::Middleware::ContentLength";
- $block->app;
+ $block->{app};
};
- my $res = $handler->($block->env);
- is_deeply $res->[1], $block->headers;
+ my $res = $handler->($block->{env});
+ is_deeply $res->[1], $block->{headers};
};
-
-__END__
-
-=== 200 response
---- app
-sub { [ 200, [ 'Content-Type' => 'text/plain' ], [ 'OK' ] ] }
---- env
-REQUEST_METHOD: GET
---- headers
-- Content-Type
-- text/plain
-- Content-Length
-- 2
-
-=== 200 response with filehandle
---- app
-sub {
- open my $fh, "<", "share/kyoto.jpg";
- [ 200, [ 'Content-Type' => 'image/jpeg' ], $fh ];
-}
---- env
-REQUEST_METHOD: GET
---- headers
-- Content-Type
-- image/jpeg
-- Content-Length
-- 2397701
-
-=== 304 no entity header
---- app
-sub {
- [ 304, [ ETag => 'Foo' ], [] ];
-}
---- env
-REQUEST_METHOD: GET
---- headers
-- ETag
-- Foo
-
-=== 200 not calculatable
---- app
-sub {
- my $body = "Hello World";
- open my $fh, "<", \$body;
- [ 200, [ 'Content-Type' => 'text/plain' ], $fh ];
-}
---- env
-REQUEST_METHOD: GET
---- headers
-- Content-Type
-- text/plain
-
-=== 200 with C-L
---- app
-sub {
- [ 200, [ 'Content-Type' => 'text/plain', 'Content-Length' => 11 ], [ "Hello World" ] ];
-}
---- env
-REQUEST_METHOD: GET
---- headers
-- Content-Type
-- text/plain
-- Content-Length
-- 11
@@ -0,0 +1,23 @@
+use strict;
+use Plack::Test;
+use Test::More;
+use HTTP::Request::Common;
+use Plack::App::File;
+
+my $app = Plack::App::File->new(file => 'README');
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 200;
+ like $res->content, qr/Plack/;
+
+ $res = $cb->(GET "/whatever");
+ is $res->content_type, 'text/plain';
+ is $res->code, 200;
+};
+
+
+
+done_testing;
@@ -0,0 +1,47 @@
+use strict;
+use Plack::Test;
+use HTTP::Request::Common;
+use Test::More;
+
+package HTTP::Error;
+sub new { bless {}, shift }
+sub throw {
+ my $class = shift;
+ die $class->new;
+}
+
+package HTTP::Error::InternalServerError;
+use base qw(HTTP::Error);
+sub code { 500 }
+
+package HTTP::Error::Forbidden;
+use base qw(HTTP::Error);
+sub code { 403 }
+sub as_string { "blah blah blah" }
+
+package main;
+
+my $app = sub {
+ my $env = shift;
+ if ($env->{PATH_INFO} eq '/secret') {
+ HTTP::Error::Forbidden->throw;
+ }
+ HTTP::Error::InternalServerError->throw;
+};
+
+use Plack::Middleware::HTTPExceptions;
+$app = Plack::Middleware::HTTPExceptions->wrap($app);
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 500;
+ is $res->content, 'Internal Server Error';
+
+ $res = $cb->(GET "/secret");
+ is $res->code, 403;
+ is $res->content, 'blah blah blah';
+};
+
+done_testing;
@@ -0,0 +1,59 @@
+use strict;
+use Plack::Test;
+use HTTP::Request::Common;
+use Test::More;
+
+package HTTP::Error;
+sub new { bless {}, shift }
+sub throw {
+ my $class = shift;
+ die $class->new;
+}
+
+package HTTP::Error::InternalServerError;
+use base qw(HTTP::Error);
+sub code { 500 }
+
+package HTTP::Error::Forbidden;
+use base qw(HTTP::Error);
+sub code { 403 }
+sub as_string { "blah blah blah" }
+
+package main;
+
+my $app = sub {
+ my $env = shift;
+ if ($env->{PATH_INFO} eq '/secret') {
+ return sub { HTTP::Error::Forbidden->throw };
+ } elsif ($env->{PATH_INFO} eq '/ok') {
+ return sub {
+ my $res = shift;
+ my $w = $res->([ 200, [ 'Content-Type', 'text/plain' ] ]);
+ $w->write("Hello");
+ $w->close;
+ };
+ }
+
+ return sub { HTTP::Error::InternalServerError->throw };
+};
+
+use Plack::Middleware::HTTPExceptions;
+$app = Plack::Middleware::HTTPExceptions->wrap($app);
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 500;
+ is $res->content, 'Internal Server Error';
+
+ $res = $cb->(GET "/secret");
+ is $res->code, 403;
+ is $res->content, 'blah blah blah';
+
+ $res = $cb->(GET "/ok");
+ is $res->code, 200;
+ is $res->content, 'Hello';
+};
+
+done_testing;
@@ -5,25 +5,47 @@ use Plack::Builder;
my $json = '{"foo":"bar"}';
-my $app = sub {
- return [ 200, [ 'Content-Type' => 'application/json' ], [ $json ] ];
-};
+my @app = (
+ sub {
+ return [ 200, [ 'Content-Type' => 'application/json' ], [ $json ] ];
+ },
+ sub {
+ return sub {
+ my $respond = shift;
+ $respond->(
+ [ 200, [ 'Content-Type' => 'application/json' ], [ $json ] ]
+ );
+ };
+ },
+ sub {
+ return sub {
+ my $respond = shift;
+ my $writer = $respond->(
+ [ 200, [ 'Content-Type' => 'application/json' ] ],
+ );
+ $writer->write( $json );
+ $writer->close;
+ };
+ },
+);
-$app = builder {
- enable "Plack::Middleware::JSONP";
- $app;
-};
+for my $app ( @app ) {
+ $app = builder {
+ enable "Plack::Middleware::JSONP";
+ $app;
+ };
-test_psgi app => $app, client => sub {
- my $cb = shift;
+ test_psgi app => $app, client => sub {
+ my $cb = shift;
- my $res = $cb->(HTTP::Request->new(GET => 'http://localhost/'));
- is $res->content_type, 'application/json';
- is $res->content, $json;
- $res = $cb->(HTTP::Request->new(GET => 'http://localhost/?callback=foo'));
- is $res->content_type, 'text/javascript';
- is $res->content, "foo($json)";
-};
+ my $res = $cb->(HTTP::Request->new(GET => 'http://localhost/'));
+ is $res->content_type, 'application/json';
+ is $res->content, $json;
+ $res = $cb->(HTTP::Request->new(GET => 'http://localhost/?callback=foo'));
+ is $res->content_type, 'text/javascript';
+ is $res->content, "foo($json)";
+ };
+}
done_testing;
@@ -0,0 +1,44 @@
+use strict;
+use Plack::Test;
+use Test::Requires qw(Log::Log4perl);
+
+use Test::More;
+use Plack::Middleware::Log4perl;
+use HTTP::Request::Common;
+
+my $test_file = "t/Plack-Middleware/log4perl.log";
+
+my $conf = <<CONF;
+log4perl.logger.plack.test = INFO, Logfile
+log4perl.appender.Logfile = Log::Log4perl::Appender::File
+log4perl.appender.Logfile.filename = $test_file
+log4perl.appender.Logfile.layout = Log::Log4perl::Layout::SimpleLayout
+CONF
+
+Log::Log4perl::init(\$conf);
+
+my $app = sub {
+ my $env = shift;
+ $env->{'psgix.logger'}->({ level => "debug", message => "This is debug" });
+ $env->{'psgix.logger'}->({ level => "info", message => "This is info" });
+ return [ 200, [], [] ];
+};
+
+$app = Plack::Middleware::Log4perl->wrap($app, category => 'plack.test');
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(GET "/");
+
+ my $log = do {
+ open my $fh, "<", $test_file;
+ join '', <$fh>;
+ };
+
+ like $log, qr/INFO - This is info/;
+ unlike $log, qr/debug/;
+};
+
+END { unlink $test_file }
+
+done_testing;
@@ -0,0 +1,36 @@
+use strict;
+use Plack::Test;
+use Test::Requires qw(Log::Dispatch::Array);
+
+use Test::More;
+use Plack::Middleware::LogDispatch;
+use HTTP::Request::Common;
+use Log::Dispatch;
+use Log::Dispatch::Array;
+
+my @logs;
+
+my $logger = Log::Dispatch->new;
+$logger->add(Log::Dispatch::Array->new(
+ min_level => 'debug',
+ array => \@logs,
+));
+
+my $app = sub {
+ my $env = shift;
+ $env->{'psgix.logger'}->({ level => "debug", message => "This is debug" });
+ return [ 200, [], [] ];
+};
+
+$app = Plack::Middleware::LogDispatch->wrap($app, logger => $logger);
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(GET "/");
+
+ is @logs, 1;
+ is $logs[0]->{level}, 'debug';
+ is $logs[0]->{message}, 'This is debug';
+};
+
+done_testing;
@@ -10,18 +10,35 @@ my $app = sub {
], [ 'Hello Foo' ] ];
};
-$app = builder {
- enable "Plack::Middleware::RearrangeHeaders";
- $app;
-};
+ {
+ my $test = "Pre-test: test that header order is not changed by default.";
+ # Don't use Plack::Test since it uses HTTP::Headers to reorder itself
+ my $res = $app->({});
-# Don't use Plack::Test since it uses HTTP::Headers to reorder itself
-my $res = $app->({});
+ is_deeply $res->[1], [
+ 'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT',
+ 'Content-Type' => 'text/plain',
+ 'ETag' => 'foo bar',
+ ],
+ $test;
+ }
-is_deeply $res->[1], [
+ {
+ my $test = "Rearrange Middleware changes the header order";
+ $app = builder {
+ enable "Plack::Middleware::RearrangeHeaders";
+ $app;
+ };
+
+ # Don't use Plack::Test since it uses HTTP::Headers to reorder itself
+ my $res = $app->({});
+
+ is_deeply $res->[1], [
'ETag' => 'foo bar',
'Content-Type' => 'text/plain',
'Last-Modified' => 'Wed, 23 Sep 2009 13:36:33 GMT',
-];
+ ],
+ $test;
+}
done_testing;
@@ -0,0 +1,30 @@
+use strict;
+use Test::More;
+use Plack::Test;
+use HTTP::Request::Common;
+
+use Plack::Middleware::Recursive;
+
+
+my $app = sub {
+ my $env = shift;
+
+ if ($env->{PATH_INFO} eq '/forwarded') {
+ is_deeply $env->{'plack.recursive.old_path_info'}, [ '/' ];
+ return [ 200, [ 'Content-Type', 'text/plain' ], [ "Hello $env->{QUERY_STRING}" ] ];
+ }
+
+ return $env->{'plack.recursive.include'}->("/forwarded?q=bar");
+};
+
+$app = Plack::Middleware::Recursive->wrap($app);
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 200;
+ is $res->content, "Hello q=bar";
+};
+
+done_testing;
@@ -0,0 +1,33 @@
+use strict;
+use Test::More;
+use Plack::Test;
+use HTTP::Request::Common;
+
+use Plack::Middleware::Recursive;
+
+my $app = sub {
+ my $env = shift;
+
+ if ($env->{PATH_INFO} eq '/forwarded') {
+ is_deeply $env->{'plack.recursive.old_path_info'}, [ '/' ];
+ return sub { $_[0]->([ 200, [ 'Content-Type', 'text/plain' ], [ "Hello $env->{QUERY_STRING}" ] ]) };
+ }
+
+ return sub {
+ my $respond = shift;
+ my $r = $env->{'plack.recursive.include'}->("/forwarded?q=bar");
+ ref $r eq 'CODE' ? $r->($respond) : $respond->($r);
+ };
+};
+
+$app = Plack::Middleware::Recursive->wrap($app);
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 200;
+ is $res->content, "Hello q=bar";
+};
+
+done_testing;
@@ -0,0 +1,31 @@
+use strict;
+use Test::More;
+use Plack::Test;
+use HTTP::Request::Common;
+
+use Plack::Middleware::Recursive;
+
+my $app = sub {
+ my $env = shift;
+
+ if ($env->{PATH_INFO} eq '/forwarded2') {
+ is_deeply $env->{'plack.recursive.old_path_info'}, [ '/', '/forwarded' ];
+ return [ 200, [ 'Content-Type', 'text/plain' ], [ "Hello $env->{QUERY_STRING}" ] ];
+ } elsif ($env->{PATH_INFO} eq '/forwarded') {
+ Plack::Recursive::ForwardRequest->throw("/forwarded2?q=bar");
+ }
+
+ Plack::Recursive::ForwardRequest->throw("/forwarded?q=bar");
+};
+
+$app = Plack::Middleware::Recursive->wrap($app);
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 200;
+ is $res->content, "Hello q=bar";
+};
+
+done_testing;
@@ -0,0 +1,34 @@
+use strict;
+use Test::More;
+use Plack::Test;
+use HTTP::Request::Common;
+
+use Plack::Middleware::Recursive;
+
+my $app = sub {
+ my $env = shift;
+
+ if ($env->{PATH_INFO} eq '/forwarded2') {
+ is_deeply $env->{'plack.recursive.old_path_info'}, [ '/', '/forwarded' ];
+ return sub { $_[0]->([ 200, [ 'Content-Type', 'text/plain' ], [ "Hello $env->{QUERY_STRING}" ] ]) };
+ } elsif ($env->{PATH_INFO} eq '/forwarded') {
+ Plack::Recursive::ForwardRequest->throw("/forwarded2?q=bar");
+ }
+
+ return sub {
+ my $respond = shift;
+ Plack::Recursive::ForwardRequest->throw("/forwarded");
+ };
+};
+
+$app = Plack::Middleware::Recursive->wrap($app);
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "/");
+ is $res->code, 200;
+ is $res->content, "Hello q=bar";
+};
+
+done_testing;
@@ -17,7 +17,7 @@ test_psgi $app, sub {
my $cb = shift;
my $res = $cb->(GET "/");
- ok $res->header('X-Runtime') >= 1;
+ ok $res->header('X-Runtime') >= 0.5;
};
done_testing;
@@ -0,0 +1,28 @@
+use strict;
+use Plack::Test;
+use Test::More;
+use Plack::Middleware::SimpleLogger;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $env = shift;
+ my $errors;
+ $env->{'psgi.errors'} = do { open my $io, ">", \$errors; $io };
+
+ $env->{'psgix.logger'}->({ level => "debug", message => "This is debug" });
+ $env->{'psgix.logger'}->({ level => "info", message => "This is info" });
+
+ return [ 200, [], [$errors] ];
+};
+
+$app = Plack::Middleware::SimpleLogger->wrap($app, level => "info");
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(GET "/");
+
+ like $res->content, qr/This is info/;
+ unlike $res->content, qr/This is debug/;
+};
+
+done_testing;
@@ -2,13 +2,19 @@ use strict;
use warnings;
use Test::More;
use Plack::Middleware::StackTrace;
+use Plack::Test;
+use HTTP::Request::Common;
-my $handler = Plack::Middleware::StackTrace->wrap(sub { die "orz" });
-my $res = $handler->(+{});
-is scalar(@$res), 3;
-is $res->[0], 500;
-is_deeply $res->[1], ['Content-Type' => 'text/html; charset=utf-8'];
-like $res->[2]->[0], qr/orz/;
+my $app = Plack::Middleware::StackTrace->wrap(sub { die "orz" });
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(GET "/");
+
+ ok $res->is_error;
+ is_deeply [ $res->content_type ], [ 'text/html', 'charset=utf-8' ];
+ like $res->content, qr/orz/;
+};
done_testing;
@@ -10,11 +10,10 @@ use Cwd;
use Plack::Test;
my $base = cwd;
-chdir "t";
my $handler = builder {
enable "Plack::Middleware::Static",
- path => sub { s!^/share/!!}, root => "$base/share";
+ path => sub { s!^/share/!!}, root => "share";
enable "Plack::Middleware::Static",
path => qr{\.(t|PL|txt)$}i, root => '.';
sub {
@@ -27,7 +26,7 @@ my %test = (
my $cb = shift;
{
- my $path = "00_compile.t";
+ my $path = "t/00_compile.t";
my $res = $cb->(GET "http://localhost/$path");
is $res->content_type, 'text/troff', 'ok case';
like $res->content, qr/use Test::More/;
@@ -58,7 +57,7 @@ my %test = (
}
{
- my $res = $cb->(GET "http://localhost/Plack-Middleware/static.txt");
+ my $res = $cb->(GET "http://localhost/t/Plack-Middleware/static.txt");
is $res->content_type, 'text/plain';
my($ct, $charset) = $res->content_type;
is $charset, 'charset=utf-8';
@@ -0,0 +1,22 @@
+use strict;
+use Test::More;
+use Test::Requires { 'CGI::Emulate::PSGI' => 0, 'CGI::Compile' => 0.03 };
+use Plack::Test;
+use HTTP::Request::Common;
+use Plack::App::WrapCGI;
+
+my $app = Plack::App::WrapCGI->new(script => "t/Plack-Middleware/cgi-bin/hello.cgi")->to_app;
+
+test_psgi app => $app, client => sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "http://localhost/?name=foo");
+ is $res->code, 200;
+ is $res->content, "Hello foo counter=1";
+
+ $res = $cb->(GET "http://localhost/?name=bar");
+ is $res->code, 200;
+ is $res->content, "Hello bar counter=2";
+};
+
+done_testing;
@@ -1,58 +0,0 @@
-use strict;
-use Test::Base;
-use Plack::Builder;
-
-filters {
- app => 'eval',
- env => 'yaml',
- headers => 'yaml',
-};
-
-plan tests => 2 * blocks;
-
-run {
- my $block = shift;
- my $handler = builder {
- enable "Plack::Middleware::Writer";
- $block->app;
- };
- my $res = $handler->($block->env);
- is_deeply $res->[1], $block->headers, "headers passed through";
- is join("", @{ $res->[2] }) . "\n", $block->body, "body accumulated";
-};
-
-__END__
-
-=== simple write
---- app
-sub {
- return sub {
- $_[0]->([ 200, [ 'Content-Type' => 'text/plain' ], [ 'OK' ] ]);
- }
-}
---- env
-REQUEST_METHOD: GET
---- headers
-- Content-Type
-- text/plain
---- body
-OK
-
-=== iterative write
---- app
-sub {
- return sub {
- my $writer = $_[0]->([ 200, [ 'Content-Type' => 'text/plain' ]]);
-
- $writer->write("O");
- $writer->write("K");
- $writer->close();
- }
-}
---- env
-REQUEST_METHOD: GET
---- headers
-- Content-Type
-- text/plain
---- body
-OK
@@ -1,7 +1,6 @@
use strict;
use warnings;
use Test::More;
-use Test::Requires qw( Path::Class );
use HTTP::Request::Common;
use Plack::Builder;
use Plack::Test;
@@ -0,0 +1,54 @@
+use strict;
+use warnings;
+use Plack::Request;
+use Test::More;
+
+my @tests = (
+ { host => 'localhost',
+ base => 'http://localhost/' },
+ { script_name => '/foo',
+ host => 'localhost',
+ base => 'http://localhost/foo' },
+ { script_name => '/foo bar',
+ host => 'localhost',
+ base => 'http://localhost/foo%20bar' },
+ { scheme => 'http',
+ host => 'localhost:91',
+ base => 'http://localhost:91/' },
+ { scheme => 'http',
+ host => 'example.com',
+ base => 'http://example.com/' },
+ { scheme => 'https',
+ host => 'example.com',
+ base => 'https://example.com/' },
+ { scheme => 'http',
+ server_name => 'example.com',
+ server_port => 80,
+ base => 'http://example.com/' },
+ { scheme => 'http',
+ server_name => 'example.com',
+ server_port => 8080,
+ base => 'http://example.com:8080/' },
+ { host => 'foobar.com',
+ server_name => 'example.com',
+ server_port => 8080,
+ base => 'http://foobar.com/' },
+);
+
+plan tests => 1*@tests;
+
+for my $block (@tests) {
+ my $env = {
+ 'psgi.url_scheme' => $block->{scheme} || 'http',
+ HTTP_HOST => $block->{host} || undef,
+ SERVER_NAME => $block->{server_name} || undef,
+ SERVER_PORT => $block->{server_port} || undef,
+ SCRIPT_NAME => $block->{script_name} || '',
+ };
+
+ my $req = Plack::Request->new($env);
+ is $req->base, $block->{base};
+}
+
+
+
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ is_deeply $req->body_parameters, { foo => 'bar' };
+ is $req->content, 'foo=bar';
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(POST "/", { foo => "bar" });
+ ok $res->is_success;
+};
+
+done_testing;
@@ -0,0 +1,23 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ is $req->content, '';
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(GET "/");
+ ok $res->is_success;
+
+ $res = $cb->(HEAD "/");
+ ok $res->is_success;
+};
+
+done_testing;
@@ -0,0 +1,24 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ is $req->content, 'body';
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $req = HTTP::Request->new(POST => "/");
+ $req->content("body");
+ $req->content_type('text/plain');
+ $req->content_length(4);
+ $cb->($req);
+};
+
+done_testing;
+
@@ -0,0 +1,38 @@
+use strict;
+use warnings;
+use Test::More;
+use HTTP::Request;
+use Plack::Test;
+use Plack::Request;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+
+ is $req->cookies->{undef}, undef;
+ is $req->cookies->{Foo}, 'Bar';
+ is $req->cookies->{Bar}, 'Baz';
+ is $req->cookies->{XXX}, 'Foo Bar';
+ is $req->cookies->{YYY}, 0;
+
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $req = HTTP::Request->new(GET => "/");
+ $req->header(Cookie => 'Foo=Bar; Bar=Baz; XXX=Foo%20Bar; YYY=0; YYY=3');
+ $cb->($req);
+};
+
+$app = sub {
+ my $req = Plack::Request->new(shift);
+ is_deeply $req->cookies, {};
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ $cb->(HTTP::Request->new(GET => "/"));
+};
+
+done_testing;
@@ -0,0 +1,21 @@
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+$Plack::Test::Impl = 'Server';
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ return [200, [], [ $req->uri ]];
+};
+
+test_psgi app => $app, client => sub {
+ my $cb = shift;
+ my $res = $cb->(GET "http://localhost/foo");
+ ok $res->content !~ /:\d+:\d+/;
+};
+
+done_testing;
+
+
@@ -0,0 +1,14 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+
+plan tests => 2;
+
+my $req = Plack::Request->new({ REMOTE_HOST => "foo.example.com" });
+is $req->remote_host, "foo.example.com";
+
+$req = Plack::Request->new({ REMOTE_HOST => '', REMOTE_ADDR => '127.0.0.1' });
+is $req->address, "127.0.0.1";
+
@@ -0,0 +1,76 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+
+my $content = qq{------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file"; filename="yappo.txt"
+Content-Type: text/plain
+
+SHOGUN
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file"; filename="yappo2.txt"
+Content-Type: text/plain
+
+SHOGUN2
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file3"; filename="yappo3.txt"
+Content-Type: text/plain
+
+SHOGUN3
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file4"; filename="yappo4.txt"
+Content-Type: text/plain
+
+SHOGUN4
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file4"; filename="yappo5.txt"
+Content-Type: text/plain
+
+SHOGUN4
+------BOUNDARY
+Content-Disposition: form-data; name="test_upload_file6"; filename="yappo6.txt"
+Content-Type: text/plain
+
+SHOGUN6
+------BOUNDARY--
+};
+$content =~ s/\r\n/\n/g;
+$content =~ s/\n/\r\n/g;
+
+{
+ open my $in, '<', \$content;
+ my $req = Plack::Request->new({
+ 'psgi.input' => $in,
+ CONTENT_LENGTH => length($content),
+ CONTENT_TYPE => 'multipart/form-data; boundary=----BOUNDARY',
+ REQUEST_METHOD => 'POST',
+ SCRIPT_NAME => '/',
+ SERVER_PORT => 80,
+ });
+
+ my @undef = $req->upload('undef');
+ is @undef, 0;
+ my $undef = $req->upload('undef');
+ is $undef, undef;
+
+ my @uploads = $req->upload('test_upload_file');
+
+ like slurp($uploads[0]), qr|^SHOGUN|;
+ like slurp($uploads[1]), qr|^SHOGUN|;
+ is slurp($req->upload('test_upload_file4')), 'SHOGUN4';
+
+ my $test_upload_file3 = $req->upload('test_upload_file3');
+ is slurp($test_upload_file3), 'SHOGUN3';
+
+ my @test_upload_file6 = $req->upload('test_upload_file6');
+ is slurp($test_upload_file6[0]), 'SHOGUN6';
+}
+
+done_testing;
+
+sub slurp {
+ my $up = shift;
+ open my $fh, "<", $up->path or die;
+ join '', <$fh>;
+}
@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $env = shift;
+ my $req = Plack::Request->new($env);
+ is $req->content, 'foo=bar';
+ is $req->content, 'foo=bar';
+
+ $req = Plack::Request->new($env);
+ is $req->content, 'foo=bar';
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(POST "/", { foo => "bar" });
+ ok $res->is_success;
+};
+
+done_testing;
@@ -0,0 +1,27 @@
+use strict;
+use Test::More;
+use Plack::Request;
+
+my $req = Plack::Request->new({
+ REQUEST_METHOD => 'GET',
+ SERVER_PROTOCOL => 'HTTP/1.1',
+ SERVER_PORT => 80,
+ SERVER_NAME => 'example.com',
+ SCRIPT_NAME => '/foo',
+ REMOTE_ADDR => '127.0.0.1',
+ 'psgi.version' => [ 1, 0 ],
+ 'psgi.input' => undef,
+ 'psgi.errors' => undef,
+ 'psgi.url_scheme' => 'http',
+});
+
+isa_ok($req, 'Plack::Request');
+
+is($req->address, '127.0.0.1', 'address');
+is($req->method, 'GET', 'method');
+is($req->protocol, 'HTTP/1.1', 'protocol');
+is($req->uri, 'http://example.com/foo', 'uri');
+is($req->port, 80, 'port');
+is($req->scheme, 'http', 'url_scheme');
+
+done_testing();
@@ -0,0 +1,25 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+use Plack::Test;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ my $b = $req->body_parameters;
+ is $b->{foo}, 'bar';
+ my $q = $req->query_parameters;
+ is $q->{bar}, 'baz';
+
+ is_deeply $req->parameters, { foo => 'bar', 'bar' => 'baz' };
+
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ $cb->(POST "/?bar=baz", { foo => "bar" });
+};
+
+done_testing;
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+
+my $req = Plack::Request->new({ QUERY_STRING => "foo=bar" });
+is_deeply $req->parameters, { foo => "bar" };
+is $req->param('foo'), "bar";
+is_deeply [ $req->param ], [ 'foo' ];
+
+$req = Plack::Request->new({ QUERY_STRING => "foo=bar&foo=baz" });
+is_deeply $req->parameters, { foo => "baz" };
+is $req->param('foo'), "baz";
+is_deeply [ $req->param('foo') ] , [ qw(bar baz) ];
+is_deeply [ $req->param ], [ 'foo' ];
+
+$req = Plack::Request->new({ QUERY_STRING => "foo=bar&foo=baz&bar=baz" });
+is_deeply $req->parameters, { foo => "baz", bar => "baz" };
+is_deeply $req->query_parameters, { foo => "baz", bar => "baz" };
+is $req->param('foo'), "baz";
+is_deeply [ $req->param('foo') ] , [ qw(bar baz) ];
+is_deeply [ sort $req->param ], [ 'bar', 'foo' ];
+
+
+done_testing;
+
@@ -0,0 +1,34 @@
+use strict;
+use Test::More;
+use Plack::Test;
+use Plack::App::URLMap;
+use Plack::Test;
+use Plack::Request;
+use HTTP::Request::Common;
+
+my $path_app = sub {
+ my $req = Plack::Request->new(shift);
+ my $res = $req->new_response(200);
+ $res->content_type('text/plain');
+ $res->content($req->path_info);
+ return $res->finalize;
+};
+
+my $app = Plack::App::URLMap->new;
+$app->map("/foo" => $path_app);
+$app->map("/" => $path_app);
+
+test_psgi app => $app->to_app, client => sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "http://localhost/foo");
+ is $res->content, '';
+
+ $res = $cb->(GET "http://localhost/foo/bar");
+ is $res->content, '/bar';
+
+ $res = $cb->(GET "http://localhost/xxx/yyy");
+ is $res->content, '/xxx/yyy';
+};
+
+done_testing;
@@ -0,0 +1,22 @@
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Plack::Test;
+use Plack::Request;
+use Try::Tiny;
+
+{
+ try {
+ my $data = 'a';
+ open my $input, "<", \$data;
+ my $req = Plack::Request->new({
+ 'psgi.input' => $input,
+ CONTENT_LENGTH => 3,
+ CONTENT_TYPE => 'application/octet-stream'
+ });
+ $req->body_parameters;
+ } catch {
+ like $_, qr/Bad Content-Length/;
+ }
+}
+
@@ -0,0 +1,22 @@
+use strict;
+use Test::More;
+use Plack::Request;
+use Plack::Test;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ return [ 200, [], [ $req->request_uri ] ];
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ my $res = $cb->(GET "http://localhost/foo%20bar");
+ is $res->content, '/foo%20bar';
+
+ $res = $cb->(GET "http://localhost:2020/FOO/bar,baz");
+ is $res->content, '/FOO/bar,baz';
+};
+
+done_testing;
@@ -0,0 +1,9 @@
+use strict;
+use warnings;
+use Test::More tests => 1;
+use Plack::Request::Upload;
+
+my $upload = Plack::Request::Upload->new(
+ filename => '/tmp/foo/bar/hoge.txt',
+);
+is $upload->basename, 'hoge.txt';
@@ -0,0 +1,29 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+use Plack::Test;
+use HTTP::Request::Common;
+
+my $file = "share/kyoto.jpg";
+
+my @backends = qw( Server MockHTTP );
+sub flip_backend { $Plack::Test::Impl = shift @backends }
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+ is $req->uploads->{image}->size, -s $file;
+ is $req->uploads->{image}->content_type, 'image/jpeg';
+ is $req->uploads->{image}->basename, 'kyoto.jpg';
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ $cb->(POST "/", Content_Type => 'form-data', Content => [
+ image => [ $file ],
+ ]);
+} while flip_backend;
+
+done_testing;
+
@@ -0,0 +1,35 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+use Plack::Test;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $req = Plack::Request->new(shift);
+
+ isa_ok $req->uploads->{foo}, 'HASH';
+ is $req->uploads->{foo}->{filename}, 'foo2.txt';
+
+ my @files = $req->upload('foo');
+ is scalar(@files), 2;
+ is $files[0]->filename, 'foo1.txt';
+ is $files[1]->filename, 'foo2.txt';
+
+ is join(', ', sort { $a cmp $b } $req->upload()), 'bar, foo';
+
+ $req->new_response(200)->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+
+ $cb->(POST "/", Content_Type => 'form-data', Content => [
+ foo => [ "t/Plack-Request/foo1.txt" ],
+ foo => [ "t/Plack-Request/foo2.txt" ],
+ bar => [ "t/Plack-Request/foo1.txt" ],
+ ]);
+};
+
+done_testing;
+
@@ -0,0 +1,88 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Request;
+
+my @tests = (
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => "",
+ },
+ uri => 'http://example.com/',
+ parameters => {} },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => "",
+ PATH_INFO => "/foo bar",
+ },
+ uri => 'http://example.com/foo%20bar',
+ parameters => {} },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => '/test.c',
+ },
+ uri => 'http://example.com/test.c',
+ parameters => {} },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => '/test.c',
+ PATH_INFO => '/info',
+ },
+ uri => 'http://example.com/test.c/info',
+ parameters => {} },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => '/test',
+ QUERY_STRING => 'dynamic=daikuma',
+ },
+ uri => 'http://example.com/test?dynamic=daikuma',
+ parameters => { dynamic => 'daikuma' } },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => '/exec/'
+ },
+ uri => 'http://example.com/exec/',
+ parameters => {} },
+ { add_env => {
+ SERVER_NAME => 'example.com'
+ },
+ uri => 'http://example.com/',
+ parameters => {} },
+ { add_env => {},
+ uri => 'http:///',
+ parameters => {} },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => "",
+ QUERY_STRING => 'aco=tie'
+ },
+ uri => 'http://example.com/?aco=tie',
+ parameters => { aco => 'tie' } },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => "",
+ QUERY_STRING => 0
+ },
+ uri => 'http://example.com/?0',
+ parameters => {} },
+ { add_env => {
+ HTTP_HOST => 'example.com',
+ SCRIPT_NAME => "/foo bar",
+ PATH_INFO => "/baz quux",
+ },
+ uri => 'http://example.com/foo%20bar/baz%20quux',
+ parameters => {} }
+);
+
+plan tests => 2 * @tests;
+
+for my $block (@tests) {
+ my $env = {SERVER_PORT => 80};
+ while (my($key, $val) = each %{ $block->{add_env} || {} }) {
+ $env->{$key} = $val;
+ }
+ my $req = Plack::Request->new($env);
+
+ is $req->uri, $block->{uri};
+ is_deeply $req->query_parameters, $block->{parameters};
+};
@@ -0,0 +1,15 @@
+use strict;
+use utf8;
+use Plack::Request;
+use HTTP::Request;
+use HTTP::Message::PSGI;
+use Test::More;
+
+my $path = "/Платежи";
+
+my $hreq = HTTP::Request->new(GET => "http://localhost" . $path);
+my $req = Plack::Request->new($hreq->to_psgi);
+
+is $req->uri->path, '/%D0%9F%D0%BB%D0%B0%D1%82%D0%B5%D0%B6%D0%B8';
+
+done_testing;
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+use FindBin;
+use Test::More;
+use Plack::Response;
+use URI;
+
+sub r($) {
+ my $res = Plack::Response->new(200);
+ $res->body(@_);
+ return $res->finalize->[2];
+}
+
+is_deeply r "Hello World", [ "Hello World" ];
+is_deeply r [ "Hello", "World" ], [ "Hello", "World" ];
+
+{
+ open my $fh, "$FindBin::Bin/body.t";
+ is_deeply r $fh, $fh;
+}
+
+{
+ my $foo = "bar";
+ open my $io, "<", \$foo;
+ is_deeply r $io, $io;
+}
+
+{
+ my $uri = URI->new("foo"); # stringified object
+ is_deeply r $uri, [ $uri ];
+}
+
+done_testing;
+
@@ -0,0 +1,24 @@
+use strict;
+use Plack::Test;
+use Test::More;
+use Plack::Response;
+use HTTP::Request::Common;
+
+my $app = sub {
+ my $res = Plack::Response->new(200);
+
+ $res->cookies->{foo} = { value => "bar", domain => '.example.com', path => '/cgi-bin' };
+ $res->cookies->{bar} = { value => "xxx yyy", expires => time + 3600 };
+ $res->finalize;
+};
+
+test_psgi $app, sub {
+ my $cb = shift;
+ my $res = $cb->(GET "/");
+
+ my @v = sort $res->header('Set-Cookie');
+ like $v[0], qr/bar=xxx%20yyy; expires=\w+, \d+-\w+-\d+ \d\d:\d\d:\d\d GMT/;
+ is $v[1], "foo=bar; domain=.example.com; path=/cgi-bin";
+};
+
+done_testing;
@@ -0,0 +1,34 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Response;
+
+{
+ my $res = Plack::Response->new(302);
+ is $res->status, 302;
+ is $res->code, 302;
+}
+
+{
+ my $res = Plack::Response->new(200, [ 'Content-Type' => 'text/plain' ]);
+ is $res->content_type, 'text/plain';
+}
+
+{
+ my $res = Plack::Response->new(200, { 'Content-Type' => 'text/plain' });
+ is $res->content_type, 'text/plain';
+}
+
+{
+ my $res = Plack::Response->new(200);
+ $res->content_type('image/png');
+ is $res->content_type, 'image/png';
+}
+
+{
+ my $res = Plack::Response->new(200);
+ $res->header('X-Foo' => "bar");
+ is $res->header('X-Foo'), "bar";
+}
+
+done_testing;
@@ -0,0 +1,21 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Response;
+
+{
+ my $res = Plack::Response->new;
+ $res->redirect('http://www.google.com/');
+ is $res->location, 'http://www.google.com/';
+ is $res->code, 302;
+
+ is_deeply $res->finalize, [ 302, [ 'Location' => 'http://www.google.com/' ], [] ];
+}
+
+{
+ my $res = Plack::Response->new;
+ $res->redirect('http://www.google.com/', 301);
+ is_deeply $res->finalize, [ 301, [ 'Location' => 'http://www.google.com/' ], [] ];
+}
+
+done_testing;
@@ -0,0 +1,51 @@
+use strict;
+use warnings;
+use Test::More;
+use Plack::Response;
+
+sub res {
+ my $res = Plack::Response->new;
+ my %v = @_;
+ while (my($k, $v) = each %v) {
+ $res->$k($v);
+ }
+ $res->finalize;
+}
+
+is_deeply(
+ res(
+ status => 200,
+ body => 'hello',
+ ),
+ [ 200, +[], [ 'hello' ] ]
+);
+is_deeply(
+ res(
+ status => 200,
+ cookies => +{
+ 'foo_sid' => +{
+ value => 'ASDFJKL:',
+ expires => 'Thu, 25-Apr-1999 00:40:33 GMT',
+ domain => 'example.com',
+ path => '/',
+ },
+ 'poo_sid' => +{
+ value => 'QWERTYUI',
+ expires => 'Thu, 25-Apr-1999 00:40:33 GMT',
+ domain => 'example.com',
+ path => '/',
+ },
+ },
+ body => 'hello',
+ ),
+ [
+ 200,
+ +[
+ 'Set-Cookie' => 'poo_sid=QWERTYUI; domain=example.com; path=/; expires=Thu, 25-Apr-1999 00:40:33 GMT',
+ 'Set-Cookie' => 'foo_sid=ASDFJKL%3A; domain=example.com; path=/; expires=Thu, 25-Apr-1999 00:40:33 GMT',
+ ],
+ [ 'hello' ],
+ ]
+);
+
+done_testing;
@@ -0,0 +1,23 @@
+use Test::More;
+use Plack::Runner;
+
+sub p {
+ my $r = Plack::Runner->new;
+ $r->parse_options(@_);
+ return {@{$r->{options}}};
+}
+
+is_deeply p(), { host => undef, port => 5000, listen => [ ':5000' ], socket => undef };
+is_deeply p('-l', '/tmp/foo.sock'),
+ { host => undef, port => undef, listen => [ '/tmp/foo.sock' ], socket => '/tmp/foo.sock' };
+is_deeply p('-o', '0.0.0.0', '--port', 9000),
+ { host => '0.0.0.0', port => 9000, listen => [ '0.0.0.0:9000' ], socket => undef };
+is_deeply p('-S', 'foo.sock'),
+ { host => undef, port => undef, listen => [ 'foo.sock' ], socket => 'foo.sock' };
+is_deeply p('-l', ':80'),
+ { host => undef, port => 80, listen => [ ':80' ], socket => undef };
+is_deeply p('-l', '10.0.0.1:80', '-l', 'unix.sock'),
+ { host => '10.0.0.1', port => 80, listen => [ '10.0.0.1:80', 'unix.sock' ], socket => 'unix.sock' };
+
+done_testing;
+
@@ -1,82 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Requires qw(Apache::Constants);
-use Plack;
-use Test::TCP;
-use LWP::UserAgent;
-use FindBin;
-use File::Path;
-
-use Plack::Test::Suite;
-
-plan skip_all => "TEST_APACHE1 is not set"
- unless $ENV{TEST_APACHE1};
-
-Plack::Test::Suite->run_server_tests(\&run_httpd);
-done_testing();
-
-my $log_filename;
-
-sub run_httpd {
- my $port = shift;
-
- my $tmpdir = $ENV{APACHE1_TMP_DIR} || File::Temp::tempdir( CLEANUP => 1 );
-
- my $httpd = $ENV{APACHE_BIN} || 'httpd';
-
- write_file("$tmpdir/app.psgi", _render_psgi());
- write_file("$tmpdir/httpd.conf", _render_conf($tmpdir, $port, "$tmpdir/app.psgi"));
- mkpath( "$tmpdir/conf" );
- write_file("$tmpdir/conf/mime.types", _render_mimetypes());
-
-
- $log_filename = "$tmpdir/error_log";
- system ("touch $log_filename");
- link($log_filename, 'err');
-
- exec "$httpd -X -F -f $tmpdir/httpd.conf" or die "couldn't start httpd : $!\n";
-}
-
-
-sub write_file {
- my($path, $content) = @_;
-
- open my $out, ">", $path or die "$path: $!";
- print $out $content;
-}
-
-sub _render_mimetypes {
- return 'text/html html htm';
-}
-
-
-sub _render_psgi {
- return <<'EOF';
-use lib "lib";
-use Plack::Test::Suite;
-
-Plack::Test::Suite->test_app_handler;
-EOF
-}
-
-sub _render_conf {
- my ($tmpdir, $port, $psgi_path) = @_;
- my $load_module = ( -f "$tmpdir/libexec/mod_perl.so" ) ? 'LoadModule perl_module libexec/mod_perl.so' : '' ;
- my $conf = <<"END";
-$load_module
-ServerRoot $tmpdir
-ServerName 127.0.0.1
-PidFile $tmpdir/httpd.pid
-LockFile $tmpdir/httpd.lock
-ErrorLog $tmpdir/error_log
-Listen $port
-
-<Location />
-SetHandler perl-script
-PerlHandler Plack::Server::Apache1
-PerlSetVar psgi_app $tmpdir/app.psgi
-</Location>
-END
- return $conf;
-}
@@ -1,67 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Requires qw(Apache2::Const);
-use Plack;
-use Test::TCP;
-use LWP::UserAgent;
-use FindBin;
-use Plack::Test::Suite;
-
-plan skip_all => "TEST_APACHE2 is not set"
- unless $ENV{TEST_APACHE2};
-
-# Note: you need to load 64bit lib to test Apache2 on OS X 10.5 or later
-
-Plack::Test::Suite->run_server_tests(\&run_httpd);
-done_testing();
-
-sub run_httpd {
- my $port = shift;
-
- my $tmpdir = $ENV{APACHE2_TMP_DIR} || File::Temp::tempdir( CLEANUP => 1 );
-
- write_file("$tmpdir/app.psgi", _render_psgi());
- write_file("$tmpdir/httpd.conf", _render_conf($tmpdir, $port, "$tmpdir/app.psgi"));
-
- exec "httpd -X -D FOREGROUND -f $tmpdir/httpd.conf";
-}
-
-sub write_file {
- my($path, $content) = @_;
-
- open my $out, ">", $path or die "$path: $!";
- print $out $content;
-}
-
-sub _render_psgi {
- return <<'EOF';
-use lib "lib";
-use Plack::Test::Suite;
-
-Plack::Test::Suite->test_app_handler;
-EOF
-}
-
-sub _render_conf {
- my ($tmpdir, $port, $psgi_path) = @_;
- <<"END";
-LoadModule perl_module libexec/apache2/mod_perl.so
-ServerRoot $tmpdir
-PidFile $tmpdir/httpd.pid
-LockFile $tmpdir/httpd.lock
-ErrorLog $tmpdir/error_log
-Listen $port
-
-<Perl>
-use Plack::Server::Apache2;
-Plack::Server::Apache2->preload("$tmpdir/app.psgi");
-</Perl>
-
-<Location />
-SetHandler perl-script
-PerlHandler Plack::Server::Apache2
-PerlSetVar psgi_app $tmpdir/app.psgi
-</Location>
-END
-}
@@ -1,33 +0,0 @@
-use strict;
-use warnings;
-use Test::Requires {
- 'HTTP::Request::AsCGI' => 1.0,
-};
-use Test::More;
-use FindBin;
-use HTTP::Request::AsCGI;
-use URI::Escape;
-use Plack;
-use Plack::Server::CGI;
-use Plack::Test::Suite;
-
-Plack::Test::Suite->runtests(sub {
- my ($name, $test, $handler) = @_;
-
- note $name;
- my $cb = sub {
- my $req = shift;
-
- my $cgi = HTTP::Request::AsCGI->new($req);
- my $c = $cgi->setup;
- eval { Plack::Server::CGI->new->run($handler) };
- my $res = $c->response;
- $res->request($req);
-
- $res;
- };
-
- $test->($cb);
-});
-
-done_testing;
@@ -0,0 +1,33 @@
+use strict;
+use Plack::Server::CGI;
+use Test::More;
+use Test::Requires {
+ 'HTTP::Request::AsCGI' => 1.2,
+};
+use HTTP::Request;
+
+my $app = sub {
+ my $env = shift;
+ return [ 200, [ "Content-Type", "text/plain" ], [ $env->{PATH_INFO} ] ];
+};
+
+my $req = HTTP::Request->new(GET => "http://localhost/foo");
+my $cgi = HTTP::Request::AsCGI->new($req);
+my $c = $cgi->setup;
+
+my $stderr;
+{
+ close STDERR;
+ open STDERR, ">", \$stderr;
+ my $s = Plack::Server::CGI->new;
+ $s->run($app);
+}
+
+my $res = $c->response;
+is $res->content, "/foo";
+like $stderr, qr/deprecated/;
+
+done_testing;
+
+
+
@@ -1,38 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Requires qw(FCGI FCGI::ProcManager);
-use Plack;
-use Plack::Server::FCGI;
-use Test::TCP;
-use LWP::UserAgent;
-use FindBin;
-use Plack::Test::Suite;
-use t::FCGIUtils;
-
-my $lighty_port;
-my $fcgi_port;
-
-test_lighty_external(
- sub {
- ($lighty_port, $fcgi_port) = @_;
- Plack::Test::Suite->run_server_tests(\&run_server, $fcgi_port, $lighty_port);
- done_testing();
- }
-);
-
-sub run_server {
- my($port, $app) = @_;
-
- $| = 0; # Test::Builder autoflushes this. reset!
-
- my $server = Plack::Server::FCGI->new(
- host => '127.0.0.1',
- port => $port,
- manager => '',
- keep_stderr => 1,
- );
- $server->run($app);
-}
-
-
@@ -1,41 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Requires { FCGI => 0, 'FCGI::Client' => 0.03 };
-use Plack;
-use Plack::Server::FCGI;
-use Test::TCP;
-use LWP::UserAgent;
-use FindBin;
-use Plack::Test::Suite;
-use t::FCGIUtils;
-
-
-use Data::Dumper;
-
-my $http_port;
-my $fcgi_port;
-
-test_fcgi_standalone(
- sub {
- ($http_port, $fcgi_port) = @_;
- Plack::Test::Suite->run_server_tests(\&run_server, $fcgi_port, $http_port);
- done_testing();
- }
-);
-
-sub run_server {
- my($port, $app) = @_;
-
- $| = 0; # Test::Builder autoflushes this. reset!
-
- my $server = Plack::Server::FCGI->new(
- host => '127.0.0.1',
- port => $port,
- manager => '',
- keep_stderr => 1,
- );
- $server->run($app);
-}
-
-
@@ -1,15 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Requires {
- 'HTTP::Parser::XS' => 0,
- 'Parallel::Prefork' => 0.04,
-};
-
-use FindBin;
-use Plack;
-use Plack::Test::Suite;
-
-Plack::Test::Suite->run_server_tests('Standalone::Prefork');
-done_testing();
-
@@ -1,12 +0,0 @@
-use strict;
-use warnings;
-use Test::More;
-use Test::Requires qw(HTTP::Parser::XS);
-
-use FindBin;
-use Plack;
-use Plack::Test::Suite;
-
-Plack::Test::Suite->run_server_tests('Standalone');
-done_testing();
-
@@ -0,0 +1,35 @@
+use strict;
+use Test::More;
+use Plack::TempBuffer;
+
+{
+ my $b = Plack::TempBuffer->new(-1);
+ $b->print("foo");
+ is $b->size, 3;
+ my $fh = $b->rewind;
+ is do { local $/; <$fh> }, 'foo';
+ $fh->seek(0, 0);
+}
+
+{
+ local $Plack::TempBuffer::MaxMemoryBufferSize = 12;
+ my $b = Plack::TempBuffer->new;
+ is $b->size, 0;
+ $b->print("foo") for 1..5;
+ is $b->size, 15;
+ my $fh = $b->rewind;
+ isa_ok $fh, 'IO::File';
+ is do { local $/; <$fh> }, ('foo' x 5);
+}
+
+{
+ local $Plack::TempBuffer::MaxMemoryBufferSize = 0;
+ my $b = Plack::TempBuffer->new(3);
+ $b->print("foo\n");
+ is $b->size, 4;
+ my $fh = $b->rewind;
+ isa_ok $fh, 'IO::File';
+ is do { local $/; <$fh> }, "foo\n";
+}
+
+done_testing;
@@ -1,37 +1,22 @@
-use Test::Base;
+use strict;
+use Test::More;
use Plack::Util;
-plan tests => 2 * blocks;
+{
+ open my $fh, "<", "/dev/null";
+ ok Plack::Util::is_real_fh($fh);
+}
-run {
- my $block = shift;
- my $res = Plack::Util::is_real_fh(eval $block->input);
+{
+ open my $fh, "<", \"foo";
+ ok ! Plack::Util::is_real_fh($fh);
+}
- ok !$@;
- ok $res == $block->ret;
-};
-
-
-__END__
-
-===
---- input
-open my $fh, "<", "/dev/null";
-$fh;
---- ret
-1
-
-===
---- input
-open my $fh, "<", \"foo"; $fh
---- ret
-0
-
-===
---- input
-use IO::File;
-IO::File->new("/dev/null");
---- ret
-1
+{
+ use IO::File;
+ my $fh = IO::File->new("/dev/null");
+ ok Plack::Util::is_real_fh($fh);
+}
+done_testing;